From 21af2f94f97e91958e9bbdb96f7588a54ecc0631 Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Sat, 2 Mar 2019 04:17:38 +1300 Subject: [PATCH 01/57] Convert the README into Markdown (#7) * Fix line endings in README CRLF -> LF * Update how licenses are presented * Move the MIT license text to a separate LICENSE file. * Fix the link to the CC-BY license. It was linking to the CC-BY-SA license text. * Convert the README to Markdown * Add the CPC reference for this version * Add download links for the PDF guide Including a badge with the download link near the top. * Minor fixes to illustrate the workflow --- LICENSE | 22 ++++++++ README | 155 ------------------------------------------------------ README.md | 146 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 168 insertions(+), 155 deletions(-) create mode 100644 LICENSE delete mode 100644 README create mode 100644 README.md diff --git a/LICENSE b/LICENSE new file mode 100644 index 000000000..e48d4df5e --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2018 Computational Atomic Structure Group + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files +except the above mentioned practical guide GRASP2018 (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE diff --git a/README b/README deleted file mode 100644 index 894a079fc..000000000 --- a/README +++ /dev/null @@ -1,155 +0,0 @@ - -======================================================================= - - General Relativistic Atomic Structure Package: - GRASP2018 - an F95 development version - -======================================================================= - -This package is a major revision of the previous GRASP2K package by -P. Jonsson, G. Gaigalas, J. Bieron, C. Froese Fischer, and I.P. Grant -Computer Physics Communication, 184, 2197 - 2203 (2013) written in -FORTRAN 77 style with COMMON and using Cray pointers for memory -management. The present version is a FORTRAN95 translation using -standard FORTRAN for memory management. In addition, COMMONS have -been replaced with MODULES, with some COMMONS merged. Some algorithms -have been changed to improve performance for large cases and -efficienty. - -The previous package, was an extension and modification of -GRASP92 by Farid Parpia, Charlotte Froese Fischer, and Ian Grant. -Computer Physics Communication, 94, 249-271 (1996) - -Development of this package was performed largely by: - Charlotte Froese Fischer email: cff@cs.ubc.ca - Gediminas Gaigalas email: Gediminas.Gaigalas@tfai.vu.lt - Per Jönsson email: per.jonsson@mau.se - Jacek Bieron email: jacek.bieron@uj.edu.pl -Please contact one of these authors if you have questions - -Supporters include: - Jörgen Ekman email: jorgen.ekman@mah.se - Ian Grant email: iangrant15@btinternet.com - - - - STRUCTURE OF THE PACKAGE - -The package has the structure shown below where executables, after sucessful -compilation, reside in the bin directory. Compiled libraries are in the lib -directory. Scripts for example runs and case studies are in folders under -grasptest. Source code is in the src directory and divided into applications -in the appl directory, libraries in the lib directory and tools in the tool -directory. - - |-bin - |-grasptest - |---case1 - |-----script - |---case1_mpi - |-----script - |-----tmp_mpi - |---case2 - |-----script - |---case2_mpi - |-----script - |-----tmp_mpi - |---case3 - |-----script - |---example1 - |-----script - |---example2 - |-----script - |---example3 - |-----script - |---example4 - |-----script - |-------tmp_mpi - |---example5 - |-----script - |-lib - |-src - |---appl - |-----HF - |-----jj2lsj90 - |-----jjgen90 - |-----rangular90 - |-----rangular90_mpi - |-----rbiotransform90 - |-----rbiotransform90_mpi - |-----rci90 - |-----rci90_mpi - |-----rcsfgenerate90 - |-----rcsfinteract90 - |-----rcsfzerofirst90 - |-----rhfs90 - |-----rmcdhf90 - |-----rmcdhf90_mpi - |-----rnucleus90 - |-----rtransition90 - |-----rtransition90_mpi - |-----rwfnestimate90 - |-----sms90 - |---lib - |-----lib9290 - |-----libdvd90 - |-----libmcp90 - |-----libmod - |-----librang90 - |-----mpi90 - |---tool - - - - PROGRAM GUIDE AND COMPILATION - -The software is distributed with a practical guide to GRASP2018 in -pdf-format. The guide, which is under Creative Commons Attribution -4.0 International — CC BY 4.0 - licence, contains full information on -how to compile and install the package. - - - - ACKNOWLEDGEMENTS - -This work was supported by the Chemical Sciences, Geosciences and -Biosciences Division, Office of Basic Energy Sciences, Office of -Science, U.S. Department of Energy who made the Pacific Sierra -translater available and the National Institute of Standards and -Technology. Computer resources were made available by Compute -Canada. CFF had research support from the Canadian NSERC Discovery Grant -2017-03851. JB acknowledges financial support of the European Regional -Development Fund in the framework of the Polish Innovation Economy -Operational Program (Contract No. POIG.02.01.00-12-023/08). - - - - MIT LICENSE -COPYRIGHT 2018 Computational Atomic Structure Group - -Permission is hereby granted, free of charge, to any person obtaining a -copy of this software and associated documentation files -except the above mentioned practical guide GRASP2018 (the "Software"), -to deal in the Software without restriction, including without limitation -the rights to use, copy, modify, merge, publish, distribute, sublicense, -and/or sell copies of the Software, and to permit persons to whom the -Software is furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE - - - - CC BY 4.0 LICENSE - -The CC BY 4.0 LICENSE is provided here -https://creativecommons.org/licenses/by-sa/4.0/legalcode - diff --git a/README.md b/README.md new file mode 100644 index 000000000..65cf4cd25 --- /dev/null +++ b/README.md @@ -0,0 +1,146 @@ +# General Relativistic Atomic Structure Package + +**GRASP2018 - an F95 development version** + +[![][manual-badge]][manual-pdf] + +This version of GRASP is a major revision of the previous GRASP2K package by [P. +Jonsson, G. Gaigalas, J. Bieron, C. Froese Fischer, and I.P. Grant Computer +Physics Communication, 184, 2197 - 2203 (2013)][grasp2k-2013] written in FORTRAN +77 style with COMMON and using Cray pointers for memory management. The present +version is a FORTRAN95 translation using standard FORTRAN for memory management. +In addition, COMMONS have been replaced with MODULES, with some COMMONS merged. +Some algorithms have been changed to improve performance for large cases and +efficiently. + +The previous package, was an extension and modification of GRASP92 by [Farid +Parpia, Charlotte Froese Fischer, and Ian Grant. Computer Physics Communication, +94, 249-271 (1996)][grasp92-1996]. + +This version of GRASP has been published in: + +> C. Froese Fischer, G. Gaigalas, P. Jönsson, J. Bieroń, +> "GRASP2018 — a Fortran 95 version of the General Relativistic Atomic Structure Package", +> Computer Physics Communications, 237, 184-187 (2018), +> https://doi.org/10.1016/j.cpc.2018.10.032 + +Development of this package was performed largely by: + +| | email | +| ------------------------- | ------------------------------| +| Charlotte Froese Fischer | cff@cs.ubc.ca | +| Gediminas Gaigalas | Gediminas.Gaigalas@tfai.vu.lt | +| Per Jönsson | per.jonsson@mau.se | +| Jacek Bieron | jacek.bieron@uj.edu.pl | + +Please contact one of these authors if you have questions. + +Supporters include: + +| | email | +| ------------------------- | ------------------------------| +| Jörgen Ekman | jorgen.ekman@mah.se | +| Ian Grant | iangrant15@btinternet.com | + + + +## Structure of the Package + +The package has the structure shown below where executables, after successful +compilation, reside in the `bin` directory. Compiled libraries are in the `lib` +directory. Scripts for example runs and case studies are in folders under +`grasptest`. Source code is in the `src` directory and divided into applications +in the `appl` directory, libraries in the `lib` directory and tools in the +`tool` directory. + +``` + |-bin + |-grasptest + |---case1 + |-----script + |---case1_mpi + |-----script + |-----tmp_mpi + |---case2 + |-----script + |---case2_mpi + |-----script + |-----tmp_mpi + |---case3 + |-----script + |---example1 + |-----script + |---example2 + |-----script + |---example3 + |-----script + |---example4 + |-----script + |-------tmp_mpi + |---example5 + |-----script + |-lib + |-src + |---appl + |-----HF + |-----jj2lsj90 + |-----jjgen90 + |-----rangular90 + |-----rangular90_mpi + |-----rbiotransform90 + |-----rbiotransform90_mpi + |-----rci90 + |-----rci90_mpi + |-----rcsfgenerate90 + |-----rcsfinteract90 + |-----rcsfzerofirst90 + |-----rhfs90 + |-----rmcdhf90 + |-----rmcdhf90_mpi + |-----rnucleus90 + |-----rtransition90 + |-----rtransition90_mpi + |-----rwfnestimate90 + |-----sms90 + |---lib + |-----lib9290 + |-----libdvd90 + |-----libmcp90 + |-----libmod + |-----librang90 + |-----mpi90 + |---tool +``` + + +## Program Guide and Compilation + +The software is distributed with a practical guide to [GRASP2018 in PDF-format +(click here to download)][manual-pdf]. The guide, which is under Creative +Commons Attribution 4.0 International (CC BY 4.0) license, contains full +information on how to compile and install the package. + + +## Acknowledgements + +This work was supported by the Chemical Sciences, Geosciences and Biosciences +Division, Office of Basic Energy Sciences, Office of Science, U.S. Department of +Energy who made the Pacific Sierra translator available and the National +Institute of Standards and Technology. Computer resources were made available by +Compute Canada. CFF had research support from the Canadian NSERC Discovery +Grant 2017-03851. JB acknowledges financial support of the European Regional +Development Fund in the framework of the Polish Innovation Economy Operational +Program (Contract No. POIG.02.01.00-12-023/08). + + +## Copyright & license + +The code in this repository is distributed under the [MIT license](LICENSE). +The accompanying guide "A practical guide to GRASP2018" is licensed separately +under [the CC-BY-4.0 (Creative Commons Attribution 4.0 International) license][cc-by]. + +[manual-pdf]: https://github.com/compas/grasp2018/releases/download/2018-12-03/GRASP2018-manual.pdf +[manual-badge]: https://img.shields.io/badge/manual-pdf-blue.svg +[grasp92-1996]: https://doi.org/10.1016/0010-4655(95)00136-0 +[grasp2k-2013]: https://doi.org/10.1016/j.cpc.2013.02.016 +[cc-by]: https://creativecommons.org/licenses/by/4.0/legalcode From e40da9e18eada44a0ea07ab26458028aaa876a2b Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Tue, 19 Mar 2019 02:04:04 +1300 Subject: [PATCH 02/57] Add a .gitignore to ignore build files (#11) --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..69353dc26 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +*.o +*.mod +lib/* +bin/* From d69fb3524bf26f4137993fdb2f79043abc8b72d5 Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Tue, 26 Mar 2019 22:57:52 +1300 Subject: [PATCH 03/57] Clean up source files (#12) * cleanup: remove executable bits The removal was done with the following command: find . -type f -not -path './.git/*' -not -path './grasptest/*' -not -path './make_environment*' -perm /uog+x -exec chmod a-x {} \; The executable flags from the make_* scripts in the root directory were not removed, even though they are not useful either. * cleanup: remove trailing whitespace and newlines Modern editors generally remove these automatically, and hence it is necessary to clean up all files. Otherwise future source change commits will contain a lot of noise with with whitespace changes, or the developer has to patch-add the source files, separating whitespace changes from meaningful changes. As both are sub-optimal, the best option is to fix all the whitespace at once. The following commands were used to clean up the whitespace: find . -type f -not -path './.git/*' -not -path './grasptest/*' -exec sed --in-place -e :a -e '/^\n*$/{$d;N;};/\n$/ba' {} \; find . -type f -not -path './.git/*' -not -path './grasptest/*' -exec sed --in-place 's/[[:space:]]\+$//' {} \; --- make_environment_gfortran_UBC | 4 +- make_environment_ifort_CC | 4 +- src/Makefile | 1 - src/appl/HF/HF.f90 | 7246 ++++++++--------- src/appl/HF/Makefile | 7 +- src/appl/Makefile | 1 - src/appl/jj2lsj90/Makefile | 4 +- src/appl/jj2lsj90/getmixblock.f90 | 206 +- src/appl/jj2lsj90/getmixblock_I.f90 | 16 +- src/appl/jj2lsj90/idigit.f90 | 20 +- src/appl/jj2lsj90/idigit_I.f90 | 14 +- src/appl/jj2lsj90/jj2lsj2K.f90 | 2 +- src/appl/jj2lsj90/jj2lsj_code.f90 | 358 +- src/appl/jj2lsj90/jj2lsj_data_1_C.f90 | 10 +- src/appl/jj2lsj90/jj2lsj_data_2_C.f90 | 2 +- src/appl/jj2lsj90/jj2lsj_data_3_C.f90 | 2 +- src/appl/jj2lsj90/lval.f90 | 36 +- src/appl/jj2lsj90/packLS.f90 | 130 +- src/appl/jjgen90/Makefile | 3 +- src/appl/jjgen90/adder.f90 | 192 +- src/appl/jjgen90/adder_I.f90 | 24 +- src/appl/jjgen90/blanda.f90 | 2096 ++--- src/appl/jjgen90/blanda_I.f90 | 38 +- src/appl/jjgen90/blandb.f90 | 2014 ++--- src/appl/jjgen90/blandb_I.f90 | 34 +- src/appl/jjgen90/blandc.f90 | 524 +- src/appl/jjgen90/blandc_I.f90 | 32 +- src/appl/jjgen90/copy7t9.f90 | 38 +- src/appl/jjgen90/copy7t9_I.f90 | 12 +- src/appl/jjgen90/fivefirst.f90 | 352 +- src/appl/jjgen90/fivefirst_I.f90 | 20 +- src/appl/jjgen90/fivelines.f90 | 214 +- src/appl/jjgen90/fivelines_I.f90 | 24 +- src/appl/jjgen90/gen.f90 | 1282 +-- src/appl/jjgen90/gen_I.f90 | 30 +- src/appl/jjgen90/genb.f90 | 1282 +-- src/appl/jjgen90/jjgen15.f90 | 158 +- src/appl/jjgen90/jjgen15.or | 4 +- src/appl/jjgen90/jjgen15b.f90 | 192 +- src/appl/jjgen90/kopp1.f90 | 78 +- src/appl/jjgen90/kopp1_I.f90 | 22 +- src/appl/jjgen90/kopp2.f90 | 118 +- src/appl/jjgen90/kopp2_I.f90 | 24 +- src/appl/jjgen90/lasa1.f90 | 46 +- src/appl/jjgen90/lasa1_I.f90 | 22 +- src/appl/jjgen90/lasa2.f90 | 36 +- src/appl/jjgen90/lasa2_I.f90 | 22 +- src/appl/jjgen90/lasax-reada.f90 | 212 +- src/appl/jjgen90/lika.f90 | 42 +- src/appl/jjgen90/lika_I.f90 | 16 +- src/appl/jjgen90/lockad.f90 | 134 +- src/appl/jjgen90/lockad_I.f90 | 20 +- src/appl/jjgen90/matain.f90 | 662 +- src/appl/jjgen90/matain_I.f90 | 38 +- src/appl/jjgen90/matbin.f90 | 496 +- src/appl/jjgen90/matbin_I.f90 | 40 +- src/appl/jjgen90/matcin.f90 | 314 +- src/appl/jjgen90/matcin_I.f90 | 30 +- src/appl/jjgen90/merge.f90 | 320 +- src/appl/jjgen90/merge_I.f90 | 20 +- src/appl/jjgen90/mergeb.f90 | 254 +- src/appl/jjgen90/mergeb_I.f90 | 14 +- src/appl/jjgen90/open79.f90 | 38 +- src/appl/jjgen90/open79_I.f90 | 14 +- src/appl/jjgen90/reada.f90 | 130 +- src/appl/jjgen90/reada_I.f90 | 20 +- src/appl/jjgen90/reffa.f90 | 222 +- src/appl/jjgen90/reffa_I.f90 | 16 +- src/appl/jjgen90/slug.f90 | 102 +- src/appl/jjgen90/slug_I.f90 | 36 +- src/appl/jjgen90/sluggo.f90 | 98 +- src/appl/jjgen90/sluggo_I.f90 | 34 +- src/appl/jjgen90/test.f90 | 74 +- src/appl/jjgen90/test_I.f90 | 22 +- src/appl/rangular90/Makefile | 3 +- src/appl/rangular90/allocCheck.f90 | 4 +- src/appl/rangular90/allocCheck_I.f90 | 8 +- src/appl/rangular90/cons_C.f90 | 10 +- src/appl/rangular90/fndbeg.f90 | 152 +- src/appl/rangular90/fndbeg_I.f90 | 22 +- src/appl/rangular90/genmcp.f90 | 104 +- src/appl/rangular90/getinf.f90 | 6 +- src/appl/rangular90/getinf_I.f90 | 14 +- src/appl/rangular90/mcp_gg.f90 | 10 +- src/appl/rangular90/mcp_gg_I.f90 | 4 +- src/appl/rangular90/outsda.f90 | 54 +- src/appl/rangular90/outsda_I.f90 | 20 +- src/appl/rangular90/setdbg.f90 | 6 +- src/appl/rangular90/setdbg_I.f90 | 4 +- src/appl/rangular90/setmcp.f90 | 84 +- src/appl/rangular90/setmcp2.f90 | 58 +- src/appl/rangular90/setmcp2_I.f90 | 24 +- src/appl/rangular90/setmcp_I.f90 | 24 +- src/appl/rangular90/setsda.f90 | 96 +- src/appl/rangular90/setsda_I.f90 | 26 +- src/appl/rangular90/setsum.f90 | 50 +- src/appl/rangular90/setsum_I.f90 | 16 +- src/appl/rangular90/settmpGG.f90 | 16 +- src/appl/rangular90/settmpGG_I.f90 | 14 +- src/appl/rangular90/sort.f90 | 526 +- src/appl/rangular90/sort_I.f90 | 26 +- src/appl/rangular90/sortmem.f90 | 484 +- src/appl/rangular90/sortmem_I.f90 | 18 +- src/appl/rangular90/strsum.f90 | 66 +- src/appl/rangular90/strsum_I.f90 | 14 +- src/appl/rangular90_mpi/Makefile | 3 +- src/appl/rangular90_mpi/fndbeg.f90 | 152 +- src/appl/rangular90_mpi/fndbeg_I.f90 | 22 +- src/appl/rangular90_mpi/genmcpmpi.f90 | 70 +- src/appl/rangular90_mpi/getinf.f90 | 4 +- src/appl/rangular90_mpi/getinf_I.f90 | 14 +- src/appl/rangular90_mpi/mcpmpi_gg.f90 | 6 +- src/appl/rangular90_mpi/mcpmpi_gg_I.f90 | 4 +- src/appl/rangular90_mpi/outsdampi.f90 | 46 +- src/appl/rangular90_mpi/outsdampi_I.f90 | 20 +- src/appl/rangular90_mpi/setdbg.f90 | 4 +- src/appl/rangular90_mpi/setdbg_I.f90 | 4 +- src/appl/rangular90_mpi/setdbgmpi.f90 | 2 +- src/appl/rangular90_mpi/setdbgmpi_I.f90 | 4 +- src/appl/rangular90_mpi/setmcp.f90 | 82 +- src/appl/rangular90_mpi/setmcp_I.f90 | 24 +- src/appl/rangular90_mpi/setmcpmpi.f90 | 24 +- src/appl/rangular90_mpi/setmcpmpi_I.f90 | 20 +- src/appl/rangular90_mpi/setsda.f90 | 96 +- src/appl/rangular90_mpi/setsda_I.f90 | 26 +- src/appl/rangular90_mpi/setsum.f90 | 50 +- src/appl/rangular90_mpi/setsum_I.f90 | 16 +- src/appl/rangular90_mpi/settmp.f90 | 56 +- src/appl/rangular90_mpi/settmp_I.f90 | 20 +- src/appl/rangular90_mpi/sort.f90 | 520 +- src/appl/rangular90_mpi/sort_I.f90 | 26 +- src/appl/rangular90_mpi/strsum.f90 | 64 +- src/appl/rangular90_mpi/strsum_I.f90 | 14 +- src/appl/rbiotransform90/Makefile | 4 +- src/appl/rbiotransform90/angdata.f90 | 62 +- src/appl/rbiotransform90/angdata_I.f90 | 20 +- src/appl/rbiotransform90/biotr.f90 | 212 +- src/appl/rbiotransform90/biotr1.f90 | 498 +- src/appl/rbiotransform90/biotr1_I.f90 | 50 +- src/appl/rbiotransform90/bndinv.f90 | 212 +- src/appl/rbiotransform90/bndinv_I.f90 | 30 +- src/appl/rbiotransform90/brkt.f90 | 58 +- src/appl/rbiotransform90/brkt_I.f90 | 14 +- src/appl/rbiotransform90/citrag.f90 | 142 +- src/appl/rbiotransform90/citrag_I.f90 | 36 +- src/appl/rbiotransform90/copvec.f90 | 20 +- src/appl/rbiotransform90/copvec_I.f90 | 22 +- src/appl/rbiotransform90/fname.f90 | 86 +- src/appl/rbiotransform90/fname_I.f90 | 16 +- src/appl/rbiotransform90/genmcp.f90 | 42 +- src/appl/rbiotransform90/genmcp_I.f90 | 22 +- src/appl/rbiotransform90/getmix.f90 | 106 +- src/appl/rbiotransform90/getmix_I.f90 | 20 +- src/appl/rbiotransform90/gets.f90 | 58 +- src/appl/rbiotransform90/gets_I.f90 | 22 +- src/appl/rbiotransform90/ichkq1.f90 | 46 +- src/appl/rbiotransform90/ichkq1_I.f90 | 18 +- src/appl/rbiotransform90/ielsum.f90 | 24 +- src/appl/rbiotransform90/ielsum_I.f90 | 18 +- src/appl/rbiotransform90/ifnmnx.f90 | 40 +- src/appl/rbiotransform90/ifnmnx_I.f90 | 20 +- src/appl/rbiotransform90/inprod.f90 | 24 +- src/appl/rbiotransform90/inprod_I.f90 | 22 +- src/appl/rbiotransform90/intrpqf.f90 | 282 +- src/appl/rbiotransform90/intrpqf_I.f90 | 28 +- src/appl/rbiotransform90/intrpqi.f90 | 280 +- src/appl/rbiotransform90/intrpqi_I.f90 | 28 +- src/appl/rbiotransform90/invmat.f90 | 64 +- src/appl/rbiotransform90/invmat_I.f90 | 22 +- src/appl/rbiotransform90/kapdata.f90 | 406 +- src/appl/rbiotransform90/kapdata_I.f90 | 20 +- src/appl/rbiotransform90/lodcslBio.f90 | 710 +- src/appl/rbiotransform90/lodcslBio_I.f90 | 16 +- src/appl/rbiotransform90/lodrwff.f90 | 248 +- src/appl/rbiotransform90/lodrwff_I.f90 | 18 +- src/appl/rbiotransform90/lodrwfi.f90 | 230 +- src/appl/rbiotransform90/lodrwfi_I.f90 | 18 +- src/appl/rbiotransform90/lulu.f90 | 64 +- src/appl/rbiotransform90/lulu_I.f90 | 24 +- src/appl/rbiotransform90/matml4.f90 | 140 +- src/appl/rbiotransform90/matml4_I.f90 | 36 +- src/appl/rbiotransform90/mcpin.f90 | 48 +- src/appl/rbiotransform90/mcpin_I.f90 | 20 +- src/appl/rbiotransform90/mcpout_gg.f90 | 274 +- src/appl/rbiotransform90/mcpout_gg_I.f90 | 22 +- src/appl/rbiotransform90/orbord.f90 | 18 +- src/appl/rbiotransform90/orbord_I.f90 | 16 +- src/appl/rbiotransform90/pamtmt.f90 | 94 +- src/appl/rbiotransform90/pamtmt_I.f90 | 24 +- src/appl/rbiotransform90/prsym.f90 | 40 +- src/appl/rbiotransform90/prsym_I.f90 | 20 +- src/appl/rbiotransform90/qqsort.f90 | 232 +- src/appl/rbiotransform90/qqsort_I.f90 | 24 +- src/appl/rbiotransform90/radfile.f90 | 70 +- src/appl/rbiotransform90/radfile_I.f90 | 16 +- src/appl/rbiotransform90/radpar.f90 | 112 +- src/appl/rbiotransform90/radpar_I.f90 | 14 +- src/appl/rbiotransform90/rintff.f90 | 40 +- src/appl/rbiotransform90/rintff_I.f90 | 20 +- src/appl/rbiotransform90/rintii.f90 | 40 +- src/appl/rbiotransform90/rintii_I.f90 | 20 +- src/appl/rbiotransform90/scalve.f90 | 20 +- src/appl/rbiotransform90/scalve_I.f90 | 20 +- src/appl/rbiotransform90/setcslb.f90 | 58 +- src/appl/rbiotransform90/setcslb_I.f90 | 16 +- src/appl/rbiotransform90/setvec.f90 | 22 +- src/appl/rbiotransform90/setvec_I.f90 | 22 +- src/appl/rbiotransform90/tcsl.f90 | 54 +- src/appl/rbiotransform90/tcsl_I.f90 | 16 +- src/appl/rbiotransform90/ti1tv.f90 | 10 +- src/appl/rbiotransform90/ti1tv_I.f90 | 10 +- src/appl/rbiotransform90/tiinig.f90 | 114 +- src/appl/rbiotransform90/tiinig_I.f90 | 32 +- src/appl/rbiotransform90/trpmat.f90 | 26 +- src/appl/rbiotransform90/trpmat_I.f90 | 24 +- src/appl/rbiotransform90/ulla.f90 | 84 +- src/appl/rbiotransform90/ulla_I.f90 | 26 +- src/appl/rbiotransform90/vecsum.f90 | 42 +- src/appl/rbiotransform90/vecsum_I.f90 | 22 +- src/appl/rbiotransform90/wrtmat.f90 | 40 +- src/appl/rbiotransform90/wrtmat_I.f90 | 26 +- src/appl/rbiotransform90_mpi/Makefile | 2 - src/appl/rbiotransform90_mpi/angdatampi.f90 | 54 +- src/appl/rbiotransform90_mpi/angdatampi_I.f90 | 20 +- src/appl/rbiotransform90_mpi/biotr1.f90 | 498 +- src/appl/rbiotransform90_mpi/biotr1_I.f90 | 50 +- src/appl/rbiotransform90_mpi/biotrmpi.f90 | 196 +- src/appl/rbiotransform90_mpi/bndinv.f90 | 212 +- src/appl/rbiotransform90_mpi/bndinv_I.f90 | 30 +- src/appl/rbiotransform90_mpi/brkt.f90 | 56 +- src/appl/rbiotransform90_mpi/brkt_I.f90 | 14 +- src/appl/rbiotransform90_mpi/citragmpi.f90 | 146 +- src/appl/rbiotransform90_mpi/citragmpi_I.f90 | 34 +- src/appl/rbiotransform90_mpi/copvec.f90 | 14 +- src/appl/rbiotransform90_mpi/copvec_I.f90 | 20 +- src/appl/rbiotransform90_mpi/fname.f90 | 86 +- src/appl/rbiotransform90_mpi/fname_I.f90 | 16 +- src/appl/rbiotransform90_mpi/getmixmpi.f90 | 100 +- src/appl/rbiotransform90_mpi/getmixmpi_I.f90 | 20 +- src/appl/rbiotransform90_mpi/getsmpi.f90 | 56 +- src/appl/rbiotransform90_mpi/getsmpi_I.f90 | 22 +- src/appl/rbiotransform90_mpi/ielsum.f90 | 26 +- src/appl/rbiotransform90_mpi/ielsum_I.f90 | 18 +- src/appl/rbiotransform90_mpi/ifnmnx.f90 | 48 +- src/appl/rbiotransform90_mpi/ifnmnx_I.f90 | 20 +- src/appl/rbiotransform90_mpi/inprod.f90 | 24 +- src/appl/rbiotransform90_mpi/inprod_I.f90 | 22 +- src/appl/rbiotransform90_mpi/intrpqf.f90 | 282 +- src/appl/rbiotransform90_mpi/intrpqf_I.f90 | 28 +- src/appl/rbiotransform90_mpi/intrpqi.f90 | 280 +- src/appl/rbiotransform90_mpi/intrpqi_I.f90 | 28 +- src/appl/rbiotransform90_mpi/invmat.f90 | 66 +- src/appl/rbiotransform90_mpi/invmat_I.f90 | 24 +- src/appl/rbiotransform90_mpi/kapdata.f90 | 406 +- src/appl/rbiotransform90_mpi/kapdata_I.f90 | 20 +- src/appl/rbiotransform90_mpi/lodcslBio.f90 | 710 +- src/appl/rbiotransform90_mpi/lodcslBio_I.f90 | 16 +- src/appl/rbiotransform90_mpi/lodrwffmpi.f90 | 242 +- src/appl/rbiotransform90_mpi/lodrwffmpi_I.f90 | 18 +- src/appl/rbiotransform90_mpi/lodrwfimpi.f90 | 224 +- src/appl/rbiotransform90_mpi/lodrwfimpi_I.f90 | 18 +- src/appl/rbiotransform90_mpi/lulu.f90 | 64 +- src/appl/rbiotransform90_mpi/lulu_I.f90 | 24 +- src/appl/rbiotransform90_mpi/matml4.f90 | 140 +- src/appl/rbiotransform90_mpi/matml4_I.f90 | 36 +- src/appl/rbiotransform90_mpi/mcpinmpi.f90 | 46 +- src/appl/rbiotransform90_mpi/mcpinmpi_I.f90 | 20 +- src/appl/rbiotransform90_mpi/mcpoutmpi_gg.f90 | 276 +- .../rbiotransform90_mpi/mcpoutmpi_gg_I.f90 | 22 +- src/appl/rbiotransform90_mpi/orbord.f90 | 18 +- src/appl/rbiotransform90_mpi/orbord_I.f90 | 16 +- src/appl/rbiotransform90_mpi/pamtmt.f90 | 94 +- src/appl/rbiotransform90_mpi/pamtmt_I.f90 | 24 +- src/appl/rbiotransform90_mpi/prsym.f90 | 40 +- src/appl/rbiotransform90_mpi/prsym_I.f90 | 20 +- src/appl/rbiotransform90_mpi/qqsortmpi.f90 | 230 +- src/appl/rbiotransform90_mpi/qqsortmpi_I.f90 | 24 +- src/appl/rbiotransform90_mpi/radfilempi.f90 | 68 +- src/appl/rbiotransform90_mpi/radfilempi_I.f90 | 16 +- src/appl/rbiotransform90_mpi/radparmpi.f90 | 112 +- src/appl/rbiotransform90_mpi/radparmpi_I.f90 | 14 +- src/appl/rbiotransform90_mpi/rintff.f90 | 40 +- src/appl/rbiotransform90_mpi/rintff_I.f90 | 20 +- src/appl/rbiotransform90_mpi/rintii.f90 | 40 +- src/appl/rbiotransform90_mpi/rintii_I.f90 | 20 +- src/appl/rbiotransform90_mpi/scalve.f90 | 20 +- src/appl/rbiotransform90_mpi/scalve_I.f90 | 20 +- src/appl/rbiotransform90_mpi/setcslampi.f90 | 54 +- src/appl/rbiotransform90_mpi/setcslampi_I.f90 | 16 +- src/appl/rbiotransform90_mpi/setcslbmpi.f90 | 54 +- src/appl/rbiotransform90_mpi/setcslbmpi_I.f90 | 14 +- src/appl/rbiotransform90_mpi/setvec.f90 | 22 +- src/appl/rbiotransform90_mpi/setvec_I.f90 | 22 +- src/appl/rbiotransform90_mpi/tcsl.f90 | 54 +- src/appl/rbiotransform90_mpi/tcsl_I.f90 | 16 +- src/appl/rbiotransform90_mpi/ti1tv.f90 | 10 +- src/appl/rbiotransform90_mpi/ti1tv_I.f90 | 10 +- src/appl/rbiotransform90_mpi/tiinig_I.f90 | 32 +- src/appl/rbiotransform90_mpi/tiinigmpi.f90 | 108 +- src/appl/rbiotransform90_mpi/tiinigmpi_I.f90 | 30 +- src/appl/rbiotransform90_mpi/trpmat.f90 | 26 +- src/appl/rbiotransform90_mpi/trpmat_I.f90 | 24 +- src/appl/rbiotransform90_mpi/ulla.f90 | 84 +- src/appl/rbiotransform90_mpi/ulla_I.f90 | 26 +- src/appl/rbiotransform90_mpi/vecsum.f90 | 42 +- src/appl/rbiotransform90_mpi/vecsum_I.f90 | 22 +- src/appl/rbiotransform90_mpi/wrtmat.f90 | 40 +- src/appl/rbiotransform90_mpi/wrtmat_I.f90 | 26 +- src/appl/rci90/Makefile | 5 +- src/appl/rci90/auxblk.f90 | 148 +- src/appl/rci90/auxblk_I.f90 | 20 +- src/appl/rci90/bessel.f90 | 244 +- src/appl/rci90/bessel_I.f90 | 24 +- src/appl/rci90/breid.f90 | 264 +- src/appl/rci90/breid_I.f90 | 24 +- src/appl/rci90/brint1.f90 | 2 +- src/appl/rci90/brint1_I.f90 | 6 +- src/appl/rci90/brint2.f90 | 2 +- src/appl/rci90/brint2_I.f90 | 6 +- src/appl/rci90/brint3.f90 | 4 +- src/appl/rci90/brint3_I.f90 | 8 +- src/appl/rci90/brint4.f90 | 4 +- src/appl/rci90/brint4_I.f90 | 8 +- src/appl/rci90/brint5.f90 | 4 +- src/appl/rci90/brint5_I.f90 | 8 +- src/appl/rci90/brint6.f90 | 4 +- src/appl/rci90/brint6_I.f90 | 8 +- src/appl/rci90/brintf.f90 | 88 +- src/appl/rci90/brintf_I.f90 | 26 +- src/appl/rci90/brra.f90 | 124 +- src/appl/rci90/brra_I.f90 | 26 +- src/appl/rci90/cxk.f90 | 362 +- src/appl/rci90/cxk_I.f90 | 30 +- src/appl/rci90/dmerge_dnicmv_I.f90 | 28 +- src/appl/rci90/dnicmv.f90 | 106 +- src/appl/rci90/dnicmv_I.f90 | 24 +- src/appl/rci90/dspevx.f90 | 364 +- src/appl/rci90/dspevx_I.f90 | 52 +- src/appl/rci90/engout.f90 | 112 +- src/appl/rci90/engout_I.f90 | 30 +- src/appl/rci90/evcout.f90 | 6 +- src/appl/rci90/funk.f90 | 168 +- src/appl/rci90/funk_I.f90 | 20 +- src/appl/rci90/funl.f90 | 120 +- src/appl/rci90/funl_I.f90 | 20 +- src/appl/rci90/fzalf.f90 | 50 +- src/appl/rci90/fzalf_I.f90 | 22 +- src/appl/rci90/genintbreit1.f90 | 2 +- src/appl/rci90/genintbreit1_I.f90 | 10 +- src/appl/rci90/genintbreit2.f90 | 2 +- src/appl/rci90/genintbreit2_I.f90 | 10 +- src/appl/rci90/genintrk.f90 | 20 +- src/appl/rci90/genintrk_I.f90 | 12 +- src/appl/rci90/genmat.f90 | 150 +- src/appl/rci90/genmat2.f90 | 116 +- src/appl/rci90/genmat2_I.f90 | 22 +- src/appl/rci90/genmat_I.f90 | 28 +- src/appl/rci90/getcid.f90 | 28 +- src/appl/rci90/getcid_I.f90 | 12 +- src/appl/rci90/hmout.f90 | 42 +- src/appl/rci90/hmout_I.f90 | 16 +- src/appl/rci90/hovlap.f90 | 42 +- src/appl/rci90/hovlap_I.f90 | 28 +- src/appl/rci90/iabint.f90 | 4 +- src/appl/rci90/iabint_I.f90 | 12 +- src/appl/rci90/indtpi.f90 | 42 +- src/appl/rci90/indtpi_I.f90 | 18 +- src/appl/rci90/iniestdm.f90 | 34 +- src/appl/rci90/iniestdm_I.f90 | 10 +- src/appl/rci90/iniestsd.f90 | 38 +- src/appl/rci90/iniestsd_I.f90 | 12 +- src/appl/rci90/inter_I.f90 | 14 +- src/appl/rci90/keint.f90 | 6 +- src/appl/rci90/keint_I.f90 | 12 +- src/appl/rci90/klamaq.f90 | 130 +- src/appl/rci90/klamaq_I.f90 | 24 +- src/appl/rci90/lodmix.f90 | 10 +- src/appl/rci90/lodmix_I.f90 | 12 +- src/appl/rci90/lodres.f90 | 68 +- src/appl/rci90/lodres_I.f90 | 14 +- src/appl/rci90/maneig.f90 | 684 +- src/appl/rci90/maneig_I.f90 | 18 +- src/appl/rci90/matrix.f90 | 56 +- src/appl/rci90/matrix_I.f90 | 12 +- src/appl/rci90/mohr.f90 | 112 +- src/appl/rci90/mohr_I.f90 | 28 +- src/appl/rci90/ncharg.f90 | 88 +- src/appl/rci90/ncharg_I.f90 | 14 +- src/appl/rci90/qed.f90 | 150 +- src/appl/rci90/qed_I.f90 | 22 +- src/appl/rci90/qed_slfen.f90 | 66 +- src/appl/rci90/qed_slfen_I.f90 | 18 +- src/appl/rci90/ratden_I.f90 | 28 +- src/appl/rci90/rci92.f90 | 208 +- src/appl/rci90/rkint.f90 | 68 +- src/appl/rci90/rkint_I.f90 | 30 +- src/appl/rci90/rkintc.f90 | 126 +- src/appl/rci90/rkintc_I.f90 | 32 +- src/appl/rci90/setcsl.f90 | 46 +- src/appl/rci90/setcsl_I.f90 | 22 +- src/appl/rci90/setdbg.f90 | 20 +- src/appl/rci90/setdbg_I.f90 | 14 +- src/appl/rci90/setham_gg.f90 | 52 +- src/appl/rci90/setham_gg_I.f90 | 5 +- src/appl/rci90/setham_to_genmat2_C.f90 | 16 +- src/appl/rci90/setmix.f90 | 48 +- src/appl/rci90/setmix_I.f90 | 18 +- src/appl/rci90/setres.f90 | 98 +- src/appl/rci90/setres_I.f90 | 20 +- src/appl/rci90/setsum.f90 | 28 +- src/appl/rci90/setsum_I.f90 | 16 +- src/appl/rci90/shield.f90 | 54 +- src/appl/rci90/shield_I.f90 | 16 +- src/appl/rci90/skint.f90 | 100 +- src/appl/rci90/skint_I.f90 | 30 +- src/appl/rci90/spodmv.f90 | 80 +- src/appl/rci90/spodmv_I.f90 | 24 +- src/appl/rci90/strsum.f90 | 228 +- src/appl/rci90/strsum_I.f90 | 14 +- src/appl/rci90/t.f90 | 14 +- src/appl/rci90/talk.f90 | 48 +- src/appl/rci90/talk_I.f90 | 34 +- src/appl/rci90/triangbreit1.f90 | 4 +- src/appl/rci90/triangbreit1_I.f90 | 10 +- src/appl/rci90/triangbreit2.f90 | 3 +- src/appl/rci90/triangbreit2_I.f90 | 10 +- src/appl/rci90/triangrk.f90 | 42 +- src/appl/rci90/triangrk_I.f90 | 20 +- src/appl/rci90/vac2.f90 | 102 +- src/appl/rci90/vac2_I.f90 | 14 +- src/appl/rci90/vac4.f90 | 150 +- src/appl/rci90/vac4_I.f90 | 14 +- src/appl/rci90/vacpol.f90 | 26 +- src/appl/rci90/vacpol_I.f90 | 14 +- src/appl/rci90/vint_I.f90 | 10 +- src/appl/rci90/vinti.f90 | 72 +- src/appl/rci90/vinti_I.f90 | 18 +- src/appl/rci90/vpint.f90 | 2 +- src/appl/rci90/vpint_I.f90 | 10 +- src/appl/rci90/vpintf.f90 | 2 +- src/appl/rci90/vpintf_I.f90 | 10 +- src/appl/rci90/wghtd5.f90 | 4 +- src/appl/rci90/wghtd5_I.f90 | 8 +- src/appl/rci90/zkf.f90 | 86 +- src/appl/rci90/zkf_I.f90 | 20 +- src/appl/rci90_mpi/Makefile | 5 +- src/appl/rci90_mpi/auxblk.f90 | 148 +- src/appl/rci90_mpi/auxblk_I.f90 | 20 +- src/appl/rci90_mpi/bessel.f90 | 244 +- src/appl/rci90_mpi/bessel_I.f90 | 24 +- src/appl/rci90_mpi/breid.f90 | 264 +- src/appl/rci90_mpi/breid_I.f90 | 24 +- src/appl/rci90_mpi/brint1.f90 | 2 +- src/appl/rci90_mpi/brint1_I.f90 | 6 +- src/appl/rci90_mpi/brint2.f90 | 2 +- src/appl/rci90_mpi/brint2_I.f90 | 6 +- src/appl/rci90_mpi/brint3.f90 | 4 +- src/appl/rci90_mpi/brint3_I.f90 | 8 +- src/appl/rci90_mpi/brint4.f90 | 4 +- src/appl/rci90_mpi/brint4_I.f90 | 8 +- src/appl/rci90_mpi/brint5.f90 | 4 +- src/appl/rci90_mpi/brint5_I.f90 | 8 +- src/appl/rci90_mpi/brint6.f90 | 4 +- src/appl/rci90_mpi/brint6_I.f90 | 8 +- src/appl/rci90_mpi/brintf.f90 | 88 +- src/appl/rci90_mpi/brintf_I.f90 | 26 +- src/appl/rci90_mpi/brra.f90 | 124 +- src/appl/rci90_mpi/brra_I.f90 | 26 +- src/appl/rci90_mpi/cxk.f90 | 362 +- src/appl/rci90_mpi/cxk_I.f90 | 30 +- src/appl/rci90_mpi/dnicmv.f90 | 98 +- src/appl/rci90_mpi/dnicmv_I.f90 | 24 +- src/appl/rci90_mpi/dspevx_I.f90 | 52 +- src/appl/rci90_mpi/engout.f90 | 112 +- src/appl/rci90_mpi/engout_I.f90 | 30 +- src/appl/rci90_mpi/evcout.f90 | 6 +- src/appl/rci90_mpi/funk.f90 | 168 +- src/appl/rci90_mpi/funk_I.f90 | 20 +- src/appl/rci90_mpi/funl.f90 | 120 +- src/appl/rci90_mpi/funl_I.f90 | 20 +- src/appl/rci90_mpi/fzalf.f90 | 50 +- src/appl/rci90_mpi/fzalf_I.f90 | 22 +- src/appl/rci90_mpi/gdsummpi_I.f90 | 12 +- src/appl/rci90_mpi/genintbreit1.f90 | 2 +- src/appl/rci90_mpi/genintbreit1_I.f90 | 10 +- src/appl/rci90_mpi/genintbreit1wrap.f90 | 2 +- src/appl/rci90_mpi/genintbreit1wrap_I.f90 | 10 +- src/appl/rci90_mpi/genintbreit2.f90 | 2 +- src/appl/rci90_mpi/genintbreit2_I.f90 | 10 +- src/appl/rci90_mpi/genintbreit2wrap.f90 | 2 +- src/appl/rci90_mpi/genintbreit2wrap_I.f90 | 10 +- src/appl/rci90_mpi/genintrk.f90 | 20 +- src/appl/rci90_mpi/genintrk_I.f90 | 12 +- src/appl/rci90_mpi/genintrkwrap.f90 | 36 +- src/appl/rci90_mpi/genintrkwrap_I.f90 | 20 +- src/appl/rci90_mpi/genmat.f90 | 150 +- src/appl/rci90_mpi/genmat2.f90 | 92 +- src/appl/rci90_mpi/genmat2_I.f90 | 22 +- src/appl/rci90_mpi/genmat_I.f90 | 28 +- src/appl/rci90_mpi/getcid.f90 | 28 +- src/appl/rci90_mpi/getcid_I.f90 | 12 +- src/appl/rci90_mpi/hmout.f90 | 42 +- src/appl/rci90_mpi/hmout_I.f90 | 16 +- src/appl/rci90_mpi/hovlap.f90 | 42 +- src/appl/rci90_mpi/hovlap_I.f90 | 28 +- src/appl/rci90_mpi/iabint.f90 | 4 +- src/appl/rci90_mpi/iabint_I.f90 | 12 +- src/appl/rci90_mpi/indtpi.f90 | 42 +- src/appl/rci90_mpi/indtpi_I.f90 | 18 +- src/appl/rci90_mpi/iniestdm.f90 | 30 +- src/appl/rci90_mpi/iniestdm_I.f90 | 10 +- src/appl/rci90_mpi/iniestsd.f90 | 38 +- src/appl/rci90_mpi/iniestsd_I.f90 | 12 +- src/appl/rci90_mpi/keint.f90 | 6 +- src/appl/rci90_mpi/keint_I.f90 | 12 +- src/appl/rci90_mpi/klamaq.f90 | 130 +- src/appl/rci90_mpi/klamaq_I.f90 | 24 +- src/appl/rci90_mpi/lodmixmpi.f90 | 10 +- src/appl/rci90_mpi/lodmixmpi_I.f90 | 12 +- src/appl/rci90_mpi/lodres.f90 | 60 +- src/appl/rci90_mpi/lodres_I.f90 | 14 +- src/appl/rci90_mpi/maneigmpi.f90 | 626 +- src/appl/rci90_mpi/maneigmpi_I.f90 | 18 +- src/appl/rci90_mpi/matrix.f90 | 54 +- src/appl/rci90_mpi/matrix_I.f90 | 12 +- src/appl/rci90_mpi/mohr.f90 | 112 +- src/appl/rci90_mpi/mohr_I.f90 | 28 +- src/appl/rci90_mpi/ncharg.f90 | 88 +- src/appl/rci90_mpi/ncharg_I.f90 | 14 +- src/appl/rci90_mpi/qed.f90 | 150 +- src/appl/rci90_mpi/qed_I.f90 | 22 +- src/appl/rci90_mpi/qed_slfen.f90 | 66 +- src/appl/rci90_mpi/qed_slfen_I.f90 | 18 +- src/appl/rci90_mpi/ratden_I.f90 | 28 +- src/appl/rci90_mpi/rci90mpi.f90 | 78 +- src/appl/rci90_mpi/rkint.f90 | 68 +- src/appl/rci90_mpi/rkint_I.f90 | 30 +- src/appl/rci90_mpi/rkintc.f90 | 124 +- src/appl/rci90_mpi/rkintc_I.f90 | 32 +- src/appl/rci90_mpi/setdbg.f90 | 20 +- src/appl/rci90_mpi/setdbg_I.f90 | 14 +- src/appl/rci90_mpi/setham_gg.f90 | 52 +- src/appl/rci90_mpi/setham_gg_I.f90 | 5 +- src/appl/rci90_mpi/setmixmpi.f90 | 28 +- src/appl/rci90_mpi/setmixmpi_I.f90 | 18 +- src/appl/rci90_mpi/setres.f90 | 90 +- src/appl/rci90_mpi/setres_I.f90 | 20 +- src/appl/rci90_mpi/setsum.f90 | 28 +- src/appl/rci90_mpi/setsum_I.f90 | 16 +- src/appl/rci90_mpi/skint.f90 | 100 +- src/appl/rci90_mpi/skint_I.f90 | 30 +- src/appl/rci90_mpi/snrc.f90 | 138 +- src/appl/rci90_mpi/snrc_I.f90 | 32 +- src/appl/rci90_mpi/spodmv.f90 | 76 +- src/appl/rci90_mpi/spodmv_I.f90 | 24 +- src/appl/rci90_mpi/strsum.f90 | 172 +- src/appl/rci90_mpi/strsum_I.f90 | 14 +- src/appl/rci90_mpi/talk.f90 | 48 +- src/appl/rci90_mpi/talk_I.f90 | 34 +- src/appl/rci90_mpi/triangbreit1.f90 | 4 +- src/appl/rci90_mpi/triangbreit1_I.f90 | 10 +- src/appl/rci90_mpi/triangbreit2.f90 | 3 +- src/appl/rci90_mpi/triangbreit2_I.f90 | 10 +- src/appl/rci90_mpi/triangrk.f90 | 42 +- src/appl/rci90_mpi/triangrk_I.f90 | 20 +- src/appl/rci90_mpi/vac2.f90 | 100 +- src/appl/rci90_mpi/vac2_I.f90 | 14 +- src/appl/rci90_mpi/vac4.f90 | 150 +- src/appl/rci90_mpi/vac4_I.f90 | 14 +- src/appl/rci90_mpi/vacpol.f90 | 26 +- src/appl/rci90_mpi/vacpol_I.f90 | 14 +- src/appl/rci90_mpi/vint.f90 | 4 +- src/appl/rci90_mpi/vint_I.f90 | 8 +- src/appl/rci90_mpi/vinti.f90 | 72 +- src/appl/rci90_mpi/vinti_I.f90 | 18 +- src/appl/rci90_mpi/vpint.f90 | 2 +- src/appl/rci90_mpi/vpint_I.f90 | 10 +- src/appl/rci90_mpi/vpintf.f90 | 2 +- src/appl/rci90_mpi/vpintf_I.f90 | 10 +- src/appl/rci90_mpi/wghtd5.f90 | 4 +- src/appl/rci90_mpi/wghtd5_I.f90 | 8 +- src/appl/rci90_mpi/zkf.f90 | 86 +- src/appl/rci90_mpi/zkf_I.f90 | 20 +- src/appl/rcsfgenerate90/Makefile | 7 +- src/appl/rcsfgenerate90/adder.f90 | 192 +- src/appl/rcsfgenerate90/adder_I.f90 | 24 +- src/appl/rcsfgenerate90/blanda.f90 | 2096 ++--- src/appl/rcsfgenerate90/blanda_I.f90 | 38 +- src/appl/rcsfgenerate90/blandb.f90 | 2014 ++--- src/appl/rcsfgenerate90/blandb_I.f90 | 34 +- src/appl/rcsfgenerate90/blandc.f90 | 524 +- src/appl/rcsfgenerate90/blandc_I.f90 | 32 +- src/appl/rcsfgenerate90/copy7t9.f90 | 38 +- src/appl/rcsfgenerate90/copy7t9_I.f90 | 12 +- src/appl/rcsfgenerate90/fivefirst.f90 | 352 +- src/appl/rcsfgenerate90/fivefirst_I.f90 | 20 +- src/appl/rcsfgenerate90/fivelines.f90 | 214 +- src/appl/rcsfgenerate90/fivelines_I.f90 | 24 +- src/appl/rcsfgenerate90/gen_I.f90 | 30 +- src/appl/rcsfgenerate90/genb.f90 | 1282 +-- src/appl/rcsfgenerate90/jjgen15b.f90 | 12 +- src/appl/rcsfgenerate90/kopp1.f90 | 78 +- src/appl/rcsfgenerate90/kopp1_I.f90 | 22 +- src/appl/rcsfgenerate90/kopp2.f90 | 118 +- src/appl/rcsfgenerate90/kopp2_I.f90 | 24 +- src/appl/rcsfgenerate90/lasa1.f90 | 46 +- src/appl/rcsfgenerate90/lasa1_I.f90 | 22 +- src/appl/rcsfgenerate90/lasa2.f90 | 36 +- src/appl/rcsfgenerate90/lasa2_I.f90 | 22 +- src/appl/rcsfgenerate90/lasax-reada.f90 | 212 +- src/appl/rcsfgenerate90/lika.f90 | 42 +- src/appl/rcsfgenerate90/lika_I.f90 | 16 +- src/appl/rcsfgenerate90/lockad.f90 | 134 +- src/appl/rcsfgenerate90/lockad_I.f90 | 20 +- src/appl/rcsfgenerate90/matain.f90 | 12 +- src/appl/rcsfgenerate90/matain_I.f90 | 38 +- src/appl/rcsfgenerate90/matbin.f90 | 496 +- src/appl/rcsfgenerate90/matbin_I.f90 | 40 +- src/appl/rcsfgenerate90/matcin.f90 | 314 +- src/appl/rcsfgenerate90/matcin_I.f90 | 30 +- src/appl/rcsfgenerate90/merge.f90 | 318 +- src/appl/rcsfgenerate90/merge_I.f90 | 20 +- src/appl/rcsfgenerate90/mergeb.f90 | 254 +- src/appl/rcsfgenerate90/mergeb_I.f90 | 14 +- src/appl/rcsfgenerate90/open79.f90 | 39 +- src/appl/rcsfgenerate90/open79_I.f90 | 14 +- src/appl/rcsfgenerate90/rcsfblock.f90 | 2 +- src/appl/rcsfgenerate90/rcsfexcitation.f90 | 62 +- src/appl/rcsfgenerate90/reada.f90 | 130 +- src/appl/rcsfgenerate90/reada_I.f90 | 20 +- src/appl/rcsfgenerate90/reffa.f90 | 220 +- src/appl/rcsfgenerate90/reffa_I.f90 | 16 +- src/appl/rcsfgenerate90/slug.f90 | 102 +- src/appl/rcsfgenerate90/slug_I.f90 | 36 +- src/appl/rcsfgenerate90/sluggo.f90 | 98 +- src/appl/rcsfgenerate90/sluggo_I.f90 | 34 +- src/appl/rcsfgenerate90/test.f90 | 74 +- src/appl/rcsfgenerate90/test_I.f90 | 22 +- src/appl/rcsfgenerate90/wrapper.f90 | 3 +- src/appl/rcsfinteract90/Interact_MR.f90 | 8 +- src/appl/rcsfinteract90/Interact_csf.f90 | 12 +- src/appl/rcsfinteract90/Makefile | 6 +- src/appl/rcsfinteract90/RCSFinteract.f90 | 24 +- src/appl/rcsfinteract90/el1INT.f90 | 14 +- src/appl/rcsfinteract90/el1INT_I.f90 | 2 +- src/appl/rcsfinteract90/getinf.f90 | 2 +- src/appl/rcsfinteract90/getinf_I.f90 | 12 +- src/appl/rcsfinteract90/lodcsl_CSF.f90 | 572 +- src/appl/rcsfinteract90/lodcsl_CSF_I.f90 | 12 +- src/appl/rcsfinteract90/lodcsl_MR.f90 | 570 +- src/appl/rcsfinteract90/onescalarINT.f90 | 2 +- src/appl/rcsfinteract90/set_CSF_list.f90 | 110 +- src/appl/rcsfinteract90/set_CSF_list_I.f90 | 10 +- src/appl/rcsfinteract90/set_CSF_number.f90 | 4 +- src/appl/rcsfinteract90/set_CSF_number_I.f90 | 10 +- src/appl/rcsfzerofirst90/Makefile | 2 +- src/appl/rcsfzerofirst90/RCSFzerofirst.f90 | 10 +- src/appl/rcsfzerofirst90/lodcsl_Part.f90 | 28 +- src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 | 10 +- src/appl/rcsfzerofirst90/lodcsl_Zero.f90 | 30 +- src/appl/rcsfzerofirst90/lodcsl_Zero_I.f90 | 0 src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 | 96 +- src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 | 8 +- src/appl/rcsfzerofirst90/set_CSF_number.f90 | 4 +- src/appl/rcsfzerofirst90/set_CSF_number_I.f90 | 10 +- src/appl/rhfs90/Makefile | 7 +- src/appl/rhfs90/engouth.f90 | 124 +- src/appl/rhfs90/engouth_I.f90 | 30 +- src/appl/rhfs90/gethfd.f90 | 174 +- src/appl/rhfs90/gethfd_I.f90 | 16 +- src/appl/rhfs90/getmixblock.f90 | 190 +- src/appl/rhfs90/getmixblock_I.f90 | 18 +- src/appl/rhfs90/hfs92.f90 | 142 +- src/appl/rhfs90/hfsgg.f90 | 484 +- src/appl/rhfs90/hfsgg_I.f90 | 14 +- src/appl/rhfs90/matelt.f90 | 102 +- src/appl/rhfs90/matelt_I.f90 | 28 +- src/appl/rhfs90/opt6_C.f90 | 12 +- src/appl/rhfs90/rinthf.f90 | 40 +- src/appl/rhfs90/rinthf_I.f90 | 20 +- src/appl/rhfs90/setdbg.f90 | 146 +- src/appl/rhfs90/setdbg_I.f90 | 14 +- src/appl/rhfs90/setsum.f90 | 58 +- src/appl/rhfs90/setsum_I.f90 | 18 +- src/appl/rhfs90/strsum.f90 | 38 +- src/appl/rhfs90/strsum_I.f90 | 14 +- src/appl/rmcdhf90/Makefile | 7 +- src/appl/rmcdhf90/cofpot.f90 | 42 +- src/appl/rmcdhf90/cofpot_I.f90 | 20 +- src/appl/rmcdhf90/consis.f90 | 34 +- src/appl/rmcdhf90/consis_I.f90 | 16 +- src/appl/rmcdhf90/csfwgt.f90 | 158 +- src/appl/rmcdhf90/csfwgt_I.f90 | 16 +- src/appl/rmcdhf90/dacon.f90 | 52 +- src/appl/rmcdhf90/dacon_I.f90 | 14 +- src/appl/rmcdhf90/dampck.f90 | 26 +- src/appl/rmcdhf90/dampck_I.f90 | 24 +- src/appl/rmcdhf90/dampor.f90 | 154 +- src/appl/rmcdhf90/dampor_I.f90 | 22 +- src/appl/rmcdhf90/defcor.f90 | 54 +- src/appl/rmcdhf90/defcor_I.f90 | 16 +- src/appl/rmcdhf90/dsubrs.f90 | 54 +- src/appl/rmcdhf90/dsubrs_I.f90 | 22 +- src/appl/rmcdhf90/eigen.f90 | 88 +- src/appl/rmcdhf90/eigen_I.f90 | 16 +- src/appl/rmcdhf90/endsum.f90 | 58 +- src/appl/rmcdhf90/endsum_I.f90 | 14 +- src/appl/rmcdhf90/engoutgg.f90 | 110 +- src/appl/rmcdhf90/engoutgg_I.f90 | 22 +- src/appl/rmcdhf90/estim.f90 | 68 +- src/appl/rmcdhf90/estim_I.f90 | 16 +- src/appl/rmcdhf90/fco.f90 | 70 +- src/appl/rmcdhf90/fco_I.f90 | 22 +- src/appl/rmcdhf90/gco.f90 | 48 +- src/appl/rmcdhf90/gco_I.f90 | 22 +- src/appl/rmcdhf90/getald.f90 | 66 +- src/appl/rmcdhf90/getald_I.f90 | 14 +- src/appl/rmcdhf90/getaldwt.f90 | 120 +- src/appl/rmcdhf90/getaldwt_I.f90 | 20 +- src/appl/rmcdhf90/getold.f90 | 174 +- src/appl/rmcdhf90/getold_I.f90 | 14 +- src/appl/rmcdhf90/getoldwt.f90 | 116 +- src/appl/rmcdhf90/getoldwt_I.f90 | 20 +- src/appl/rmcdhf90/getscd.f90 | 638 +- src/appl/rmcdhf90/getscd_I.f90 | 22 +- src/appl/rmcdhf90/hmout.f90 | 102 +- src/appl/rmcdhf90/hmout_I.f90 | 20 +- src/appl/rmcdhf90/improv.f90 | 194 +- src/appl/rmcdhf90/improv_I.f90 | 24 +- src/appl/rmcdhf90/in.f90 | 160 +- src/appl/rmcdhf90/in_I.f90 | 26 +- src/appl/rmcdhf90/ispar.f90 | 16 +- src/appl/rmcdhf90/ispar_I.f90 | 14 +- src/appl/rmcdhf90/itjpo.f90 | 14 +- src/appl/rmcdhf90/itjpo_I.f90 | 14 +- src/appl/rmcdhf90/lagcon.f90 | 70 +- src/appl/rmcdhf90/lagcon_I.f90 | 18 +- src/appl/rmcdhf90/lodcsh2GG.f90 | 598 +- src/appl/rmcdhf90/lodcsh2GG_I.f90 | 18 +- src/appl/rmcdhf90/maneig.f90 | 204 +- src/appl/rmcdhf90/maneig_I.f90 | 26 +- src/appl/rmcdhf90/matrix.f90 | 362 +- src/appl/rmcdhf90/matrix_I.f90 | 12 +- src/appl/rmcdhf90/maxarr.f90 | 36 +- src/appl/rmcdhf90/maxarr_I.f90 | 16 +- src/appl/rmcdhf90/mpi_s.f90 | 10 +- src/appl/rmcdhf90/newco.f90 | 132 +- src/appl/rmcdhf90/newco_I.f90 | 18 +- src/appl/rmcdhf90/newe.f90 | 156 +- src/appl/rmcdhf90/newe_I.f90 | 30 +- src/appl/rmcdhf90/orbout.f90 | 38 +- src/appl/rmcdhf90/orbout_I.f90 | 16 +- src/appl/rmcdhf90/orthor.f90 | 112 +- src/appl/rmcdhf90/orthor_I.f90 | 18 +- src/appl/rmcdhf90/orthy.f90 | 286 +- src/appl/rmcdhf90/orthy_I.f90 | 20 +- src/appl/rmcdhf90/out.f90 | 84 +- src/appl/rmcdhf90/out_I.f90 | 24 +- src/appl/rmcdhf90/outbnd.f90 | 28 +- src/appl/rmcdhf90/outbnd_I.f90 | 18 +- src/appl/rmcdhf90/prtrsl.f90 | 70 +- src/appl/rmcdhf90/prtrsl_I.f90 | 14 +- src/appl/rmcdhf90/prwf.f90 | 106 +- src/appl/rmcdhf90/prwf_I.f90 | 16 +- src/appl/rmcdhf90/rscfvu.f90 | 132 +- src/appl/rmcdhf90/scf.f90 | 382 +- src/appl/rmcdhf90/scf_I.f90 | 18 +- src/appl/rmcdhf90/setcof.f90 | 1030 +-- src/appl/rmcdhf90/setcof_I.f90 | 18 +- src/appl/rmcdhf90/setcsl.f90 | 64 +- src/appl/rmcdhf90/setcsl_I.f90 | 20 +- src/appl/rmcdhf90/setdbg.f90 | 184 +- src/appl/rmcdhf90/setdbg_I.f90 | 16 +- src/appl/rmcdhf90/setham.f90 | 466 +- src/appl/rmcdhf90/setham_I.f90 | 20 +- src/appl/rmcdhf90/setlag.f90 | 364 +- src/appl/rmcdhf90/setlag_I.f90 | 16 +- src/appl/rmcdhf90/setmcp.f90 | 174 +- src/appl/rmcdhf90/setmcp_I.f90 | 22 +- src/appl/rmcdhf90/setmix.f90 | 36 +- src/appl/rmcdhf90/setmix_I.f90 | 16 +- src/appl/rmcdhf90/setsum.f90 | 36 +- src/appl/rmcdhf90/setsum_I.f90 | 16 +- src/appl/rmcdhf90/setxuv.f90 | 36 +- src/appl/rmcdhf90/setxuv_I.f90 | 16 +- src/appl/rmcdhf90/setxv.f90 | 34 +- src/appl/rmcdhf90/setxv_I.f90 | 16 +- src/appl/rmcdhf90/setxz.f90 | 20 +- src/appl/rmcdhf90/setxz_I.f90 | 16 +- src/appl/rmcdhf90/solve.f90 | 426 +- src/appl/rmcdhf90/solve_I.f90 | 24 +- src/appl/rmcdhf90/strsum.f90 | 194 +- src/appl/rmcdhf90/strsum_I.f90 | 14 +- src/appl/rmcdhf90/xpot.f90 | 120 +- src/appl/rmcdhf90/xpot_I.f90 | 16 +- src/appl/rmcdhf90/ypot.f90 | 114 +- src/appl/rmcdhf90/ypot_I.f90 | 16 +- src/appl/rmcdhf90_mpi/Makefile | 5 +- src/appl/rmcdhf90_mpi/cofpotmpi.f90 | 42 +- src/appl/rmcdhf90_mpi/cofpotmpi_I.f90 | 20 +- src/appl/rmcdhf90_mpi/consis.f90 | 34 +- src/appl/rmcdhf90_mpi/consis_I.f90 | 16 +- src/appl/rmcdhf90_mpi/csfwgt.f90 | 158 +- src/appl/rmcdhf90_mpi/csfwgt_I.f90 | 16 +- src/appl/rmcdhf90_mpi/dacon.f90 | 52 +- src/appl/rmcdhf90_mpi/dacon_I.f90 | 14 +- src/appl/rmcdhf90_mpi/dampck.f90 | 26 +- src/appl/rmcdhf90_mpi/dampck_I.f90 | 24 +- src/appl/rmcdhf90_mpi/dampor.f90 | 152 +- src/appl/rmcdhf90_mpi/dampor_I.f90 | 22 +- src/appl/rmcdhf90_mpi/defcor.f90 | 54 +- src/appl/rmcdhf90_mpi/defcor_I.f90 | 16 +- src/appl/rmcdhf90_mpi/dsubrs.f90 | 54 +- src/appl/rmcdhf90_mpi/dsubrs_I.f90 | 22 +- src/appl/rmcdhf90_mpi/eigen.f90 | 88 +- src/appl/rmcdhf90_mpi/eigen_I.f90 | 16 +- src/appl/rmcdhf90_mpi/endsum.f90 | 58 +- src/appl/rmcdhf90_mpi/endsum_I.f90 | 14 +- src/appl/rmcdhf90_mpi/engoutgg.f90 | 110 +- src/appl/rmcdhf90_mpi/engoutgg_I.f90 | 22 +- src/appl/rmcdhf90_mpi/estim.f90 | 68 +- src/appl/rmcdhf90_mpi/estim_I.f90 | 16 +- src/appl/rmcdhf90_mpi/fco.f90 | 70 +- src/appl/rmcdhf90_mpi/fco_I.f90 | 22 +- src/appl/rmcdhf90_mpi/gco.f90 | 48 +- src/appl/rmcdhf90_mpi/gco_I.f90 | 22 +- src/appl/rmcdhf90_mpi/getaldmpi.f90 | 60 +- src/appl/rmcdhf90_mpi/getaldmpi_I.f90 | 14 +- src/appl/rmcdhf90_mpi/getaldwt.f90 | 122 +- src/appl/rmcdhf90_mpi/getaldwt_I.f90 | 20 +- src/appl/rmcdhf90_mpi/getoldmpi.f90 | 174 +- src/appl/rmcdhf90_mpi/getoldmpi_I.f90 | 16 +- src/appl/rmcdhf90_mpi/getoldwt.f90 | 120 +- src/appl/rmcdhf90_mpi/getoldwt_I.f90 | 22 +- src/appl/rmcdhf90_mpi/getscdmpi.f90 | 626 +- src/appl/rmcdhf90_mpi/getscdmpi_I.f90 | 22 +- src/appl/rmcdhf90_mpi/hmoutmpi.f90 | 20 +- src/appl/rmcdhf90_mpi/hmoutmpi_I.f90 | 20 +- src/appl/rmcdhf90_mpi/improvmpi.f90 | 188 +- src/appl/rmcdhf90_mpi/improvmpi_I.f90 | 24 +- src/appl/rmcdhf90_mpi/in.f90 | 160 +- src/appl/rmcdhf90_mpi/in_I.f90 | 26 +- src/appl/rmcdhf90_mpi/ispar.f90 | 16 +- src/appl/rmcdhf90_mpi/ispar_I.f90 | 14 +- src/appl/rmcdhf90_mpi/itjpo.f90 | 14 +- src/appl/rmcdhf90_mpi/itjpo_I.f90 | 14 +- src/appl/rmcdhf90_mpi/lagcon.f90 | 70 +- src/appl/rmcdhf90_mpi/lagcon_I.f90 | 18 +- src/appl/rmcdhf90_mpi/lodcsh2GG.f90 | 598 +- src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 | 18 +- src/appl/rmcdhf90_mpi/lodcslmpiGG.f90 | 18 +- src/appl/rmcdhf90_mpi/lodcslmpiGG_I.f90 | 4 +- src/appl/rmcdhf90_mpi/maneigmpi.f90 | 198 +- src/appl/rmcdhf90_mpi/maneigmpi_I.f90 | 26 +- src/appl/rmcdhf90_mpi/matrixmpi.f90 | 356 +- src/appl/rmcdhf90_mpi/matrixmpi_I.f90 | 12 +- src/appl/rmcdhf90_mpi/maxarr.f90 | 36 +- src/appl/rmcdhf90_mpi/maxarr_I.f90 | 16 +- src/appl/rmcdhf90_mpi/newcompi.f90 | 130 +- src/appl/rmcdhf90_mpi/newcompi_I.f90 | 18 +- src/appl/rmcdhf90_mpi/newe.f90 | 156 +- src/appl/rmcdhf90_mpi/newe_I.f90 | 30 +- src/appl/rmcdhf90_mpi/orbout.f90 | 38 +- src/appl/rmcdhf90_mpi/orbout_I.f90 | 16 +- src/appl/rmcdhf90_mpi/orthor.f90 | 108 +- src/appl/rmcdhf90_mpi/orthor_I.f90 | 18 +- src/appl/rmcdhf90_mpi/orthy.f90 | 286 +- src/appl/rmcdhf90_mpi/orthy_I.f90 | 20 +- src/appl/rmcdhf90_mpi/out.f90 | 84 +- src/appl/rmcdhf90_mpi/out_I.f90 | 24 +- src/appl/rmcdhf90_mpi/outbnd.f90 | 28 +- src/appl/rmcdhf90_mpi/outbnd_I.f90 | 18 +- src/appl/rmcdhf90_mpi/prtrsl.f90 | 70 +- src/appl/rmcdhf90_mpi/prtrsl_I.f90 | 14 +- src/appl/rmcdhf90_mpi/prwf.f90 | 106 +- src/appl/rmcdhf90_mpi/prwf_I.f90 | 16 +- src/appl/rmcdhf90_mpi/rscfmpivu.f90 | 92 +- src/appl/rmcdhf90_mpi/scfmpi.f90 | 368 +- src/appl/rmcdhf90_mpi/scfmpi_I.f90 | 18 +- src/appl/rmcdhf90_mpi/setcof.f90 | 992 +-- src/appl/rmcdhf90_mpi/setcof_I.f90 | 18 +- src/appl/rmcdhf90_mpi/setcslmpi.f90 | 38 +- src/appl/rmcdhf90_mpi/setcslmpi_I.f90 | 20 +- src/appl/rmcdhf90_mpi/setdbg.f90 | 182 +- src/appl/rmcdhf90_mpi/setdbg_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setdbgmpi.f90 | 14 +- src/appl/rmcdhf90_mpi/setdbgmpi_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setham.f90 | 474 +- src/appl/rmcdhf90_mpi/setham_I.f90 | 20 +- src/appl/rmcdhf90_mpi/setlagmpi.f90 | 356 +- src/appl/rmcdhf90_mpi/setlagmpi_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setmcp.f90 | 174 +- src/appl/rmcdhf90_mpi/setmcp_I.f90 | 22 +- src/appl/rmcdhf90_mpi/setmix.f90 | 36 +- src/appl/rmcdhf90_mpi/setmix_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setsum.f90 | 36 +- src/appl/rmcdhf90_mpi/setsum_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setxuv.f90 | 36 +- src/appl/rmcdhf90_mpi/setxuv_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setxv.f90 | 34 +- src/appl/rmcdhf90_mpi/setxv_I.f90 | 16 +- src/appl/rmcdhf90_mpi/setxz.f90 | 20 +- src/appl/rmcdhf90_mpi/setxz_I.f90 | 16 +- src/appl/rmcdhf90_mpi/solve.f90 | 426 +- src/appl/rmcdhf90_mpi/solve_I.f90 | 24 +- src/appl/rmcdhf90_mpi/strsum.f90 | 194 +- src/appl/rmcdhf90_mpi/strsum_I.f90 | 14 +- src/appl/rmcdhf90_mpi/xpot.f90 | 120 +- src/appl/rmcdhf90_mpi/xpot_I.f90 | 16 +- src/appl/rmcdhf90_mpi/ypot.f90 | 114 +- src/appl/rmcdhf90_mpi/ypot_I.f90 | 16 +- src/appl/rnucleus90/Makefile | 6 +- src/appl/rnucleus90/estrms.f90 | 36 +- src/appl/rnucleus90/estrms_I.f90 | 18 +- src/appl/rnucleus90/geniso.f90 | 200 +- src/appl/rnucleus90/getcpr.f90 | 78 +- src/appl/rnucleus90/getcpr_I.f90 | 20 +- src/appl/rnucleus90/isodata | 10 +- src/appl/rnucleus90/skfun.f90 | 50 +- src/appl/rnucleus90/skfun_I.f90 | 18 +- src/appl/rtransition90/Makefile | 3 +- src/appl/rtransition90/alclla.f90 | 80 +- src/appl/rtransition90/alclla_I.f90 | 16 +- src/appl/rtransition90/alcnma.f90 | 62 +- src/appl/rtransition90/alcnma_I.f90 | 18 +- src/appl/rtransition90/alcnsa.f90 | 98 +- src/appl/rtransition90/alcnsa_I.f90 | 18 +- src/appl/rtransition90/alcnta.f90 | 56 +- src/appl/rtransition90/alcnta_I.f90 | 18 +- src/appl/rtransition90/angdata.f90 | 116 +- src/appl/rtransition90/angdata_I.f90 | 22 +- src/appl/rtransition90/bessj.f90 | 218 +- src/appl/rtransition90/bessj_I.f90 | 18 +- src/appl/rtransition90/bioscl.f90 | 128 +- src/appl/rtransition90/brkt.f90 | 56 +- src/appl/rtransition90/brkt_I.f90 | 14 +- src/appl/rtransition90/connect.f90 | 42 +- src/appl/rtransition90/connect_I.f90 | 14 +- src/appl/rtransition90/cpmix.f90 | 108 +- src/appl/rtransition90/cpmix_I.f90 | 18 +- src/appl/rtransition90/csfm.f90 | 6 +- src/appl/rtransition90/csfm_I.f90 | 14 +- src/appl/rtransition90/engout1.f90 | 70 +- src/appl/rtransition90/engout1_I.f90 | 32 +- src/appl/rtransition90/fname.f90 | 48 +- src/appl/rtransition90/fname_I.f90 | 16 +- src/appl/rtransition90/getosd.f90 | 236 +- src/appl/rtransition90/getosd_I.f90 | 16 +- src/appl/rtransition90/getrmp.f90 | 192 +- src/appl/rtransition90/getrmp_I.f90 | 14 +- src/appl/rtransition90/ichkq1.f90 | 46 +- src/appl/rtransition90/ichkq1_I.f90 | 18 +- src/appl/rtransition90/iqr.f90 | 14 +- src/appl/rtransition90/iqr_I.f90 | 18 +- src/appl/rtransition90/isparr.f90 | 26 +- src/appl/rtransition90/isparr_I.f90 | 16 +- src/appl/rtransition90/itjpor.f90 | 26 +- src/appl/rtransition90/itjpor_I.f90 | 16 +- src/appl/rtransition90/jcupr.f90 | 36 +- src/appl/rtransition90/jcupr_I.f90 | 18 +- src/appl/rtransition90/jqsr.f90 | 18 +- src/appl/rtransition90/jqsr_I.f90 | 20 +- src/appl/rtransition90/ldcsl1.f90 | 6 +- src/appl/rtransition90/ldcsl1_I.f90 | 10 +- src/appl/rtransition90/ldcsl2.f90 | 64 +- src/appl/rtransition90/ldcsl2_I.f90 | 16 +- src/appl/rtransition90/ldlbl1.f90 | 2 +- src/appl/rtransition90/ldlbl1_I.f90 | 10 +- src/appl/rtransition90/ldlbl2.f90 | 2 +- src/appl/rtransition90/ldlbl2_I.f90 | 10 +- src/appl/rtransition90/lodcslm.f90 | 776 +- src/appl/rtransition90/lodcslm_I.f90 | 16 +- src/appl/rtransition90/lodrwff.f90 | 164 +- src/appl/rtransition90/lodrwff_I.f90 | 16 +- src/appl/rtransition90/lodrwfi.f90 | 168 +- src/appl/rtransition90/lodrwfi_I.f90 | 16 +- src/appl/rtransition90/mctin.f90 | 86 +- src/appl/rtransition90/mctin_I.f90 | 20 +- src/appl/rtransition90/mctout_gg.f90 | 204 +- src/appl/rtransition90/mctout_gg_I.f90 | 20 +- src/appl/rtransition90/merg12.f90 | 394 +- src/appl/rtransition90/merg12_I.f90 | 20 +- src/appl/rtransition90/mrgcsl.f90 | 38 +- src/appl/rtransition90/mrgcsl_I.f90 | 16 +- src/appl/rtransition90/oscl.f90 | 446 +- src/appl/rtransition90/oscl_I.f90 | 16 +- src/appl/rtransition90/printa.f90 | 180 +- src/appl/rtransition90/printaLS.f90 | 12 +- src/appl/rtransition90/printaLS_I.f90 | 12 +- src/appl/rtransition90/printa_I.f90 | 30 +- src/appl/rtransition90/readmix.f90 | 82 +- src/appl/rtransition90/readmix_I.f90 | 20 +- src/appl/rtransition90/setcsl.f90 | 64 +- src/appl/rtransition90/setcsl_I.f90 | 14 +- src/appl/rtransition90/setcslm.f90 | 64 +- src/appl/rtransition90/setcslm_I.f90 | 14 +- src/appl/rtransition90/spme.f90 | 358 +- src/appl/rtransition90/spme_I.f90 | 26 +- src/appl/rtransition90/strsum.f90 | 44 +- src/appl/rtransition90/strsum_I.f90 | 18 +- src/appl/rtransition90/testmix.f90 | 62 +- src/appl/rtransition90/testmix_I.f90 | 14 +- src/appl/rtransition90/trsort.f90 | 444 +- src/appl/rtransition90/trsort_I.f90 | 26 +- src/appl/rtransition90_mpi/Makefile | 3 +- src/appl/rtransition90_mpi/alclla.f90 | 80 +- src/appl/rtransition90_mpi/alclla_I.f90 | 16 +- src/appl/rtransition90_mpi/alcnma.f90 | 62 +- src/appl/rtransition90_mpi/alcnma_I.f90 | 18 +- src/appl/rtransition90_mpi/alcnsa.f90 | 98 +- src/appl/rtransition90_mpi/alcnsa_I.f90 | 18 +- src/appl/rtransition90_mpi/alcnta.f90 | 56 +- src/appl/rtransition90_mpi/alcnta_I.f90 | 18 +- src/appl/rtransition90_mpi/angdatampi.f90 | 112 +- src/appl/rtransition90_mpi/angdatampi_I.f90 | 22 +- src/appl/rtransition90_mpi/bessj.f90 | 218 +- src/appl/rtransition90_mpi/bessj_I.f90 | 18 +- src/appl/rtransition90_mpi/biosclmpi.f90 | 126 +- src/appl/rtransition90_mpi/brkt.f90 | 56 +- src/appl/rtransition90_mpi/brkt_I.f90 | 14 +- src/appl/rtransition90_mpi/connect.f90 | 42 +- src/appl/rtransition90_mpi/connect_I.f90 | 14 +- src/appl/rtransition90_mpi/cpmix.f90 | 110 +- src/appl/rtransition90_mpi/cpmix_I.f90 | 18 +- src/appl/rtransition90_mpi/csfm.f90 | 6 +- src/appl/rtransition90_mpi/csfm_I.f90 | 14 +- src/appl/rtransition90_mpi/engout1.f90 | 70 +- src/appl/rtransition90_mpi/engout1_I.f90 | 32 +- src/appl/rtransition90_mpi/fname.f90 | 48 +- src/appl/rtransition90_mpi/fname_I.f90 | 16 +- src/appl/rtransition90_mpi/getosdmpi.f90 | 194 +- src/appl/rtransition90_mpi/getosdmpi_I.f90 | 16 +- src/appl/rtransition90_mpi/getrmpmpi.f90 | 190 +- src/appl/rtransition90_mpi/getrmpmpi_I.f90 | 14 +- src/appl/rtransition90_mpi/iqr.f90 | 14 +- src/appl/rtransition90_mpi/iqr_I.f90 | 18 +- src/appl/rtransition90_mpi/isparr.f90 | 26 +- src/appl/rtransition90_mpi/isparr_I.f90 | 16 +- src/appl/rtransition90_mpi/itjpor.f90 | 26 +- src/appl/rtransition90_mpi/itjpor_I.f90 | 16 +- src/appl/rtransition90_mpi/jcupr.f90 | 36 +- src/appl/rtransition90_mpi/jcupr_I.f90 | 18 +- src/appl/rtransition90_mpi/jqsr.f90 | 18 +- src/appl/rtransition90_mpi/jqsr_I.f90 | 20 +- src/appl/rtransition90_mpi/ldcsl1mpi.f90 | 6 +- src/appl/rtransition90_mpi/ldcsl1mpi_I.f90 | 10 +- src/appl/rtransition90_mpi/ldcsl2mpi.f90 | 62 +- src/appl/rtransition90_mpi/ldcsl2mpi_I.f90 | 16 +- src/appl/rtransition90_mpi/ldlbl1.f90 | 4 +- src/appl/rtransition90_mpi/ldlbl1_I.f90 | 10 +- src/appl/rtransition90_mpi/ldlbl2.f90 | 2 +- src/appl/rtransition90_mpi/ldlbl2_I.f90 | 10 +- src/appl/rtransition90_mpi/lodcslm.f90 | 776 +- src/appl/rtransition90_mpi/lodcslm_I.f90 | 16 +- src/appl/rtransition90_mpi/lodrwffmpi.f90 | 162 +- src/appl/rtransition90_mpi/lodrwffmpi_I.f90 | 16 +- src/appl/rtransition90_mpi/lodrwfimpi.f90 | 166 +- src/appl/rtransition90_mpi/lodrwfimpi_I.f90 | 16 +- src/appl/rtransition90_mpi/mctinmpi.f90 | 82 +- src/appl/rtransition90_mpi/mctinmpi_I.f90 | 20 +- src/appl/rtransition90_mpi/mctoutmpi_gg.f90 | 208 +- src/appl/rtransition90_mpi/mctoutmpi_gg_I.f90 | 20 +- src/appl/rtransition90_mpi/merg12mpi.f90 | 392 +- src/appl/rtransition90_mpi/merg12mpi_I.f90 | 20 +- src/appl/rtransition90_mpi/mrgcslmpi.f90 | 36 +- src/appl/rtransition90_mpi/mrgcslmpi_I.f90 | 16 +- src/appl/rtransition90_mpi/osclmpi.f90 | 446 +- src/appl/rtransition90_mpi/osclmpi_I.f90 | 18 +- src/appl/rtransition90_mpi/printa.f90 | 180 +- src/appl/rtransition90_mpi/printaLS.f90 | 12 +- src/appl/rtransition90_mpi/printaLS_I.f90 | 12 +- src/appl/rtransition90_mpi/printa_I.f90 | 30 +- src/appl/rtransition90_mpi/readmixmpi.f90 | 80 +- src/appl/rtransition90_mpi/readmixmpi_I.f90 | 20 +- src/appl/rtransition90_mpi/setcsl.f90 | 64 +- src/appl/rtransition90_mpi/setcsl_I.f90 | 14 +- src/appl/rtransition90_mpi/setcslm.f90 | 64 +- src/appl/rtransition90_mpi/setcslm_I.f90 | 14 +- src/appl/rtransition90_mpi/spme.f90 | 358 +- src/appl/rtransition90_mpi/spme_I.f90 | 26 +- src/appl/rtransition90_mpi/strsum.f90 | 40 +- src/appl/rtransition90_mpi/strsum_I.f90 | 18 +- src/appl/rtransition90_mpi/testmix.f90 | 64 +- src/appl/rtransition90_mpi/testmix_I.f90 | 14 +- src/appl/rtransition90_mpi/trsortmpi.f90 | 442 +- src/appl/rtransition90_mpi/trsortmpi_I.f90 | 26 +- src/appl/rwfnestimate90/Makefile | 1 - src/appl/rwfnestimate90/erwf.f90 | 88 +- src/appl/rwfnestimate90/frmhyd.f90 | 80 +- src/appl/rwfnestimate90/frmhyd_I.f90 | 22 +- src/appl/rwfnestimate90/frmrwf.f90 | 144 +- src/appl/rwfnestimate90/frmrwf_I.f90 | 26 +- src/appl/rwfnestimate90/frmtfp.f90 | 60 +- src/appl/rwfnestimate90/frmtfp_I.f90 | 20 +- src/appl/rwfnestimate90/genrwf.f90 | 250 +- src/appl/rwfnestimate90/genrwf_I.f90 | 12 +- src/appl/rwfnestimate90/getinf_I.f90 | 12 +- src/appl/rwfnestimate90/getinfo.f90 | 126 +- src/appl/rwfnestimate90/prtrem.f90 | 102 +- src/appl/rwfnestimate90/prtrem_I.f90 | 18 +- src/appl/rwfnestimate90/sbstep.f90 | 406 +- src/appl/rwfnestimate90/sbstep_I.f90 | 24 +- src/appl/rwfnestimate90/screenpar.f90 | 38 +- src/appl/rwfnestimate90/screenpar_I.f90 | 18 +- src/appl/rwfnestimate90/setdbg.f90 | 112 +- src/appl/rwfnestimate90/setdbg_I.f90 | 12 +- src/appl/rwfnestimate90/setsum.f90 | 52 +- src/appl/rwfnestimate90/setsum_I.f90 | 12 +- src/appl/rwfnestimate90/solvh.f90 | 272 +- src/appl/rwfnestimate90/solvh_I.f90 | 28 +- src/appl/rwfnestimate90/strsum.f90 | 104 +- src/appl/rwfnestimate90/strsum_I.f90 | 12 +- src/appl/rwfnestimate90/summry.f90 | 38 +- src/appl/rwfnestimate90/summry_I.f90 | 22 +- src/appl/rwfnestimate90/tail.f90 | 200 +- src/appl/rwfnestimate90/tail_I.f90 | 36 +- src/appl/rwfnestimate90/tfpot.f90 | 102 +- src/appl/rwfnestimate90/tfpot_I.f90 | 12 +- src/appl/rwfnestimate90/wrtrwf.f90 | 90 +- src/appl/rwfnestimate90/wrtrwf_I.f90 | 12 +- src/appl/sms90/Makefile | 5 +- src/appl/sms90/densmcp.f90 | 272 +- src/appl/sms90/densmcp_I.f90 | 28 +- src/appl/sms90/densnew.f90 | 176 +- src/appl/sms90/densnew_I.f90 | 28 +- src/appl/sms90/dvpot_C.f90 | 2 +- src/appl/sms90/engout.f90 | 120 +- src/appl/sms90/engout_I.f90 | 30 +- src/appl/sms90/gco.f90 | 46 +- src/appl/sms90/gco_I.f90 | 22 +- src/appl/sms90/getmixblock.f90 | 194 +- src/appl/sms90/getmixblock_I.f90 | 18 +- src/appl/sms90/getsmd.f90 | 174 +- src/appl/sms90/getsmd_I.f90 | 16 +- src/appl/sms90/polint.f90 | 96 +- src/appl/sms90/polint_I.f90 | 28 +- src/appl/sms90/rintdens.f90 | 36 +- src/appl/sms90/rintdens_I.f90 | 18 +- src/appl/sms90/rintiso.f90 | 36 +- src/appl/sms90/rintiso_I.f90 | 18 +- src/appl/sms90/setdbg.f90 | 146 +- src/appl/sms90/setdbg_I.f90 | 14 +- src/appl/sms90/setmcp.f90 | 140 +- src/appl/sms90/setmcp_I.f90 | 16 +- src/appl/sms90/setsum.f90 | 50 +- src/appl/sms90/setsum_I.f90 | 18 +- src/appl/sms90/sms.f90 | 8 +- src/appl/sms90/sms1_C.f90 | 10 +- src/appl/sms90/sms92.f90 | 144 +- src/appl/sms90/sms_I.f90 | 14 +- src/appl/sms90/smsmcp.f90 | 232 +- src/appl/sms90/smsmcp_I.f90 | 18 +- src/appl/sms90/smsnew.f90 | 106 +- src/appl/sms90/smsnew_I.f90 | 18 +- src/appl/sms90/strsum.f90 | 124 +- src/appl/sms90/strsum_I.f90 | 14 +- src/appl/sms90/teilst_C.f90 | 2 +- src/appl/sms90/vinti.f90 | 70 +- src/appl/sms90/vinti_I.f90 | 18 +- src/appl/sms90/wghtd5.f90 | 154 +- src/appl/sms90/wghtd5_I.f90 | 14 +- src/lib/Makefile | 2 - src/lib/lib9290/Makefile | 2 +- src/lib/lib9290/alcbuf.f90 | 38 +- src/lib/lib9290/alcbuf_I.f90 | 16 +- src/lib/lib9290/arctan.f90 | 56 +- src/lib/lib9290/arctan_I.f90 | 20 +- src/lib/lib9290/calen.f90 | 16 +- src/lib/lib9290/calen_I.f90 | 18 +- src/lib/lib9290/cgamma.f90 | 232 +- src/lib/lib9290/cgamma_I.f90 | 24 +- src/lib/lib9290/clrx.f90 | 78 +- src/lib/lib9290/clrx_I.f90 | 24 +- src/lib/lib9290/convrt.f90 | 62 +- src/lib/lib9290/convrt2.f90 | 70 +- src/lib/lib9290/convrt2_I.f90 | 22 +- src/lib/lib9290/convrt_I.f90 | 20 +- src/lib/lib9290/convrt_double.f90 | 72 +- src/lib/lib9290/convrt_double_I.f90 | 20 +- src/lib/lib9290/cord.f90 | 120 +- src/lib/lib9290/cord_I.f90 | 24 +- src/lib/lib9290/count.f90 | 118 +- src/lib/lib9290/count_I.f90 | 24 +- src/lib/lib9290/cre.f90 | 34 +- src/lib/lib9290/cre_I.f90 | 20 +- src/lib/lib9290/cslh.f90 | 54 +- src/lib/lib9290/cslh_I.f90 | 22 +- src/lib/lib9290/dcbsrw.f90 | 290 +- src/lib/lib9290/dcbsrw_I.f90 | 32 +- src/lib/lib9290/dinit.f90 | 36 +- src/lib/lib9290/dinit_I.f90 | 24 +- src/lib/lib9290/dmerge.f90 | 42 +- src/lib/lib9290/dmerge_I.f90 | 30 +- src/lib/lib9290/dpbdt.f90 | 60 +- src/lib/lib9290/dpbdt_I.f90 | 16 +- src/lib/lib9290/draw.f90 | 172 +- src/lib/lib9290/draw_I.f90 | 26 +- src/lib/lib9290/es.f90 | 76 +- src/lib/lib9290/es_I.f90 | 22 +- src/lib/lib9290/factt.f90 | 48 +- src/lib/lib9290/factt_I.f90 | 14 +- src/lib/lib9290/getrsl.f90 | 214 +- src/lib/lib9290/getrsl_I.f90 | 18 +- src/lib/lib9290/getyn.f90 | 32 +- src/lib/lib9290/getyn_I.f90 | 14 +- src/lib/lib9290/ichkq1.f90 | 50 +- src/lib/lib9290/ichkq1_I.f90 | 18 +- src/lib/lib9290/ichkq2.f90 | 50 +- src/lib/lib9290/ichkq2_I.f90 | 18 +- src/lib/lib9290/ichop.f90 | 40 +- src/lib/lib9290/ichop_I.f90 | 18 +- src/lib/lib9290/icopy.f90 | 34 +- src/lib/lib9290/icopy_I.f90 | 24 +- src/lib/lib9290/iniest2.f90 | 82 +- src/lib/lib9290/iniest2_I.f90 | 30 +- src/lib/lib9290/interp.f90 | 204 +- src/lib/lib9290/interp_I.f90 | 32 +- src/lib/lib9290/intrpq.f90 | 288 +- src/lib/lib9290/intrpq_I.f90 | 26 +- src/lib/lib9290/iq.f90 | 18 +- src/lib/lib9290/iq_I.f90 | 18 +- src/lib/lib9290/ispar.f90 | 32 +- src/lib/lib9290/ispar_I.f90 | 16 +- src/lib/lib9290/items.f90 | 216 +- src/lib/lib9290/items_I.f90 | 22 +- src/lib/lib9290/itjpo.f90 | 26 +- src/lib/lib9290/itjpo_I.f90 | 16 +- src/lib/lib9290/itrig.f90 | 32 +- src/lib/lib9290/itrig_I.f90 | 20 +- src/lib/lib9290/jcup.f90 | 36 +- src/lib/lib9290/jcup_I.f90 | 18 +- src/lib/lib9290/jqs.f90 | 18 +- src/lib/lib9290/jqs_I.f90 | 20 +- src/lib/lib9290/ldigit.f90 | 32 +- src/lib/lib9290/ldigit_I.f90 | 16 +- src/lib/lib9290/lodcsh.f90 | 82 +- src/lib/lib9290/lodcsh2.f90 | 606 +- src/lib/lib9290/lodcsh2_I.f90 | 18 +- src/lib/lib9290/lodcsh_I.f90 | 18 +- src/lib/lib9290/lodcsl.f90 | 710 +- src/lib/lib9290/lodcsl_I.f90 | 16 +- src/lib/lib9290/lodiso.f90 | 78 +- src/lib/lib9290/lodiso_I.f90 | 14 +- src/lib/lib9290/lodrwf.f90 | 138 +- src/lib/lib9290/lodrwf_I.f90 | 16 +- src/lib/lib9290/lodstate.f90 | 94 +- src/lib/lib9290/lodstate_I.f90 | 12 +- src/lib/lib9290/ltab.f90 | 62 +- src/lib/lib9290/ltab_I.f90 | 22 +- src/lib/lib9290/nucpot.f90 | 156 +- src/lib/lib9290/nucpot_I.f90 | 14 +- src/lib/lib9290/openfl.f90 | 40 +- src/lib/lib9290/openfl_I.f90 | 24 +- src/lib/lib9290/orthsc.f90 | 138 +- src/lib/lib9290/orthsc_I.f90 | 14 +- src/lib/lib9290/pack.f90 | 38 +- src/lib/lib9290/pack_I.f90 | 22 +- src/lib/lib9290/parsjl.f90 | 234 +- src/lib/lib9290/parsjl_I.f90 | 28 +- src/lib/lib9290/posfile.f90 | 54 +- src/lib/lib9290/posfile_I.f90 | 20 +- src/lib/lib9290/prsrcn.f90 | 186 +- src/lib/lib9290/prsrcn_I.f90 | 22 +- src/lib/lib9290/prsrsl.f90 | 198 +- src/lib/lib9290/prsrsl_I.f90 | 18 +- src/lib/lib9290/quad.f90 | 78 +- src/lib/lib9290/quad_I.f90 | 18 +- src/lib/lib9290/radgrd.f90 | 146 +- src/lib/lib9290/radgrd_I.f90 | 14 +- src/lib/lib9290/rint.f90 | 44 +- src/lib/lib9290/rint_I.f90 | 20 +- src/lib/lib9290/rinti.f90 | 120 +- src/lib/lib9290/rinti_I.f90 | 20 +- src/lib/lib9290/setcon.f90 | 66 +- src/lib/lib9290/setcon_I.f90 | 14 +- src/lib/lib9290/setcsh.f90 | 84 +- src/lib/lib9290/setcsh_I.f90 | 20 +- src/lib/lib9290/setcsla.f90 | 64 +- src/lib/lib9290/setcsla_I.f90 | 18 +- src/lib/lib9290/setcsll.f90 | 140 +- src/lib/lib9290/setcsll_I.f90 | 28 +- src/lib/lib9290/setiso.f90 | 72 +- src/lib/lib9290/setiso_I.f90 | 16 +- src/lib/lib9290/setj.f90 | 214 +- src/lib/lib9290/setj_I.f90 | 32 +- src/lib/lib9290/setmc.f90 | 38 +- src/lib/lib9290/setmc_I.f90 | 14 +- src/lib/lib9290/setpot.f90 | 78 +- src/lib/lib9290/setpot_I.f90 | 18 +- src/lib/lib9290/setqic.f90 | 94 +- src/lib/lib9290/setqic_I.f90 | 14 +- src/lib/lib9290/setqna.f90 | 192 +- src/lib/lib9290/setqna_I.f90 | 18 +- src/lib/lib9290/setrwfa.f90 | 66 +- src/lib/lib9290/setrwfa_I.f90 | 16 +- src/lib/lib9290/skrc.f90 | 92 +- src/lib/lib9290/skrc_I.f90 | 28 +- src/lib/lib9290/slater.f90 | 70 +- src/lib/lib9290/slater_I.f90 | 24 +- src/lib/lib9290/speak.f90 | 56 +- src/lib/lib9290/speak_I.f90 | 32 +- src/lib/lib9290/spicmv2.f90 | 52 +- src/lib/lib9290/spicmv2_I.f90 | 24 +- src/lib/lib9290/start.f90 | 314 +- src/lib/lib9290/start_I.f90 | 28 +- src/lib/lib9290/starttime.f90 | 42 +- src/lib/lib9290/starttime_I.f90 | 18 +- src/lib/lib9290/stoptime.f90 | 68 +- src/lib/lib9290/stoptime_I.f90 | 18 +- src/lib/lib9290/yzk.f90 | 212 +- src/lib/lib9290/yzk_I.f90 | 24 +- src/lib/libdvd90/Makefile | 7 +- src/lib/libdvd90/Makefile_Ser | 7 +- src/lib/libdvd90/Makefile_mpi | 7 +- src/lib/libdvd90/adds_I.f90 | 30 +- src/lib/libdvd90/dvdrvr_I.f90 | 74 +- src/lib/libdvd90/dvdson.f90 | 1250 +-- src/lib/libdvd90/dvdson_I.f90 | 58 +- src/lib/libdvd90/gdvd.f90 | 176 +- src/lib/libdvd90/gdvd_I.f90 | 60 +- src/lib/libdvd90/iniest.f90 | 150 +- src/lib/libdvd90/iniest_I.f90 | 28 +- src/lib/libdvd90/initdvd_I.f90 | 42 +- src/lib/libdvd90/mgs_nrm_I.f90 | 26 +- src/lib/libdvd90/multbc_I.f90 | 28 +- src/lib/libdvd90/newvec_I.f90 | 50 +- src/lib/libdvd90/ovflow_I.f90 | 32 +- src/lib/libdvd90/tstsel_I.f90 | 44 +- src/lib/libmcp90/Makefile | 0 src/lib/libmcp90/cxk.f90 | 4 +- src/lib/libmcp90/cxk_I.f90 | 30 +- src/lib/libmcp90/talk.f90 | 48 +- src/lib/libmcp90/talk_I.f90 | 34 +- src/lib/libmod/AME_C.f90 | 6 +- src/lib/libmod/Makefile | 2 +- src/lib/libmod/bcore_C.f90 | 12 +- src/lib/libmod/bess_C.f90 | 18 +- src/lib/libmod/bilst_C.f90 | 14 +- src/lib/libmod/biorb_C.f90 | 20 +- src/lib/libmod/blim_C.f90 | 14 +- src/lib/libmod/blk_C.f90 | 24 +- src/lib/libmod/blkidx_C.f90 | 10 +- src/lib/libmod/buffer_C.f90 | 12 +- src/lib/libmod/cffmat_C.f90 | 14 +- src/lib/libmod/ciimat_C.f90 | 14 +- src/lib/libmod/cimat_C.f90 | 16 +- src/lib/libmod/cnc_C.f90 | 14 +- src/lib/libmod/coeils_C.f90 | 14 +- src/lib/libmod/cons_C.f90 | 10 +- src/lib/libmod/core_C.f90 | 10 +- src/lib/libmod/corre_C.f90 | 12 +- src/lib/libmod/coun_C.f90 | 12 +- src/lib/libmod/couple_C.f90 | 22 +- src/lib/libmod/cteilsrk_C.f90 | 10 +- src/lib/libmod/cuto_C.f90 | 12 +- src/lib/libmod/damp_C.f90 | 10 +- src/lib/libmod/debug_C.f90 | 18 +- src/lib/libmod/decide_C.f90 | 12 +- src/lib/libmod/def_C.f90 | 42 +- src/lib/libmod/default_C.f90 | 12 +- src/lib/libmod/dumx_C.f90 | 10 +- src/lib/libmod/eigv_C.f90 | 10 +- src/lib/libmod/eigvec1_C.f90 | 10 +- src/lib/libmod/facts_C.f90 | 14 +- src/lib/libmod/fixd_C.f90 | 14 +- src/lib/libmod/foparm_C.f90 | 12 +- src/lib/libmod/fposition_C.f90 | 10 +- src/lib/libmod/grid_C.f90 | 14 +- src/lib/libmod/hblock_C.f90 | 14 +- src/lib/libmod/hmat_C.f90 | 18 +- src/lib/libmod/horb_C.f90 | 10 +- src/lib/libmod/hydpar_C.f90 | 12 +- src/lib/libmod/iccu_C.f90 | 6 +- src/lib/libmod/int_C.f90 | 18 +- src/lib/libmod/invt_C.f90 | 12 +- src/lib/libmod/iounit_C.f90 | 10 +- src/lib/libmod/jj2lsj_C.f90 | 146 +- src/lib/libmod/jj2lsjbio_C.f90 | 4 +- src/lib/libmod/jlabl_C.f90 | 12 +- src/lib/libmod/jqjc_C.f90 | 12 +- src/lib/libmod/keilst_C.f90 | 14 +- src/lib/libmod/kkstart_C.f90 | 14 +- src/lib/libmod/kkstartbreit_C.f90 | 4 +- src/lib/libmod/l1_C.f90 | 14 +- src/lib/libmod/l2_C.f90 | 14 +- src/lib/libmod/lagr_C.f90 | 12 +- src/lib/libmod/left_C.f90 | 12 +- src/lib/libmod/lib92p_C.f90 | 12 +- src/lib/libmod/lic13_C.f90 | 12 +- src/lib/libmod/m_C.f90 | 18 +- src/lib/libmod/mcp_C.f90 | 14 +- src/lib/libmod/mcpa_C.f90 | 12 +- src/lib/libmod/mcpb_C.f90 | 12 +- src/lib/libmod/mcpdata_C.f90 | 10 +- src/lib/libmod/memory_man.f90 | 48 +- src/lib/libmod/memory_man.f90_PROFILING | 48 +- src/lib/libmod/ncc_C.f90 | 10 +- src/lib/libmod/ncdist_C.f90 | 12 +- src/lib/libmod/node_C.f90 | 10 +- src/lib/libmod/npar_C.f90 | 28 +- src/lib/libmod/npot_C.f90 | 14 +- src/lib/libmod/offd_C.f90 | 10 +- src/lib/libmod/orb_C.f90 | 20 +- src/lib/libmod/orba_C.f90 | 12 +- src/lib/libmod/orbord_C.f90 | 10 +- src/lib/libmod/orthct_C.f90 | 10 +- src/lib/libmod/osc_C.f90 | 22 +- src/lib/libmod/ovl_C.f90 | 12 +- src/lib/libmod/parameter_def_M.f90 | 16 +- src/lib/libmod/peav_C.f90 | 10 +- src/lib/libmod/pos_C.f90 | 14 +- src/lib/libmod/pote_C.f90 | 12 +- src/lib/libmod/prnt_C.f90 | 16 +- src/lib/libmod/qedcut_C.f90 | 4 +- src/lib/libmod/rang_Int_C.f90 | 6 +- src/lib/libmod/ribojj11_C.f90 | 6 +- src/lib/libmod/ribojj9_C.f90 | 6 +- src/lib/libmod/ribojj_C.f90 | 6 +- src/lib/libmod/sacoef_C.f90 | 2 +- src/lib/libmod/sbc_C.f90 | 10 +- src/lib/libmod/sbdat1_C.f90 | 16 +- src/lib/libmod/sbdat_C.f90 | 28 +- src/lib/libmod/scf_C.f90 | 22 +- src/lib/libmod/stat_C.f90 | 8 +- src/lib/libmod/stor_C.f90 | 12 +- src/lib/libmod/syma_C.f90 | 10 +- src/lib/libmod/tatb_C.f90 | 12 +- src/lib/libmod/terms_C.f90 | 14 +- src/lib/libmod/titl_C.f90 | 12 +- src/lib/libmod/vast_kind_param_M.f90 | 4 +- src/lib/libmod/vinlst_C.f90 | 14 +- src/lib/libmod/vpilst_C.f90 | 14 +- src/lib/libmod/wave_C.f90 | 20 +- src/lib/libmod/wchblk_C.f90 | 12 +- src/lib/libmod/wfac_C.f90 | 12 +- src/lib/libmod/where_C.f90 | 12 +- src/lib/libmod/whfrom_C.f90 | 12 +- src/lib/librang90/Gracah1.f90 | 54 +- src/lib/librang90/Gracah1_I.f90 | 2 +- src/lib/librang90/Makefile | 0 src/lib/librang90/ReadMe | 12 +- src/lib/librang90/Rmew3jj.f90 | 2 +- src/lib/librang90/Rmew5jj.f90 | 2 +- src/lib/librang90/Rmew7bjj.f90 | 2 +- src/lib/librang90/awp1jjg.f90 | 2 +- src/lib/librang90/c1e0sm.f90 | 2 +- src/lib/librang90/dracah.f90 | 98 +- src/lib/librang90/dracah_I.f90 | 32 +- src/lib/librang90/eile.f90 | 2 +- src/lib/librang90/eile_I.f90 | 2 +- src/lib/librang90/el1.f90 | 12 +- src/lib/librang90/el1_I.f90 | 2 +- src/lib/librang90/itrexg.f90 | 2 +- src/lib/librang90/ittk.f90 | 18 +- src/lib/librang90/ittk_I.f90 | 2 +- src/lib/librang90/ixjtik.f90 | 20 +- src/lib/librang90/ixjtik_I.f90 | 2 +- src/lib/librang90/jthn.f90 | 4 +- src/lib/librang90/mes.f90 | 2 +- src/lib/librang90/nine.f90 | 104 +- src/lib/librang90/nine0.f90 | 102 +- src/lib/librang90/nine0_I.f90 | 2 +- src/lib/librang90/nine_I.f90 | 2 +- src/lib/librang90/oneparticlejj.f90 | 6 +- src/lib/librang90/onescalar.f90 | 4 +- src/lib/librang90/recop00.f90 | 2 +- src/lib/librang90/sixj.f90 | 310 +- src/lib/librang90/sixj1.f90 | 92 +- src/lib/librang90/sixj1_I.f90 | 2 +- src/lib/librang90/sixj2.f90 | 218 +- src/lib/librang90/sixj2_I.f90 | 4 +- src/lib/librang90/sixj3.f90 | 366 +- src/lib/librang90/sixj35.f90 | 126 +- src/lib/librang90/sixj35_I.f90 | 2 +- src/lib/librang90/sixj3_I.f90 | 4 +- src/lib/librang90/sixj4.f90 | 82 +- src/lib/librang90/sixj4_I.f90 | 2 +- src/lib/librang90/sixj5.f90 | 68 +- src/lib/librang90/sixj5_I.f90 | 2 +- src/lib/librang90/snrc.f90 | 140 +- src/lib/librang90/snrc_I.f90 | 32 +- src/lib/mpi90/cpath.f90 | 44 +- src/lib/mpi90/cpath_I.f90 | 2 +- src/lib/mpi90/cslhmpi.f90 | 10 +- src/lib/mpi90/cslhmpi_I.f90 | 2 +- src/lib/mpi90/iniestmpi.f90 | 96 +- src/lib/mpi90/iniestmpi_I.f90 | 4 +- src/lib/mpi90/lodcslmpi.f90 | 18 +- src/lib/mpi90/lodcslmpi_I.f90 | 4 +- src/lib/mpi90/lodrwfmpi.f90 | 6 +- src/lib/mpi90/lodrwfmpi_I.f90 | 2 +- src/lib/mpi90/mpi_C.f90 | 12 +- src/lib/mpi90/mpiu.f90 | 8 +- src/lib/mpi90/setisompi.f90 | 6 +- src/lib/mpi90/setisompi_I.f90 | 4 +- src/lib/mpi90/setrwfmpi.f90 | 8 +- src/lib/mpi90/setrwfmpi_I.f90 | 4 +- src/lib/mpi90/spicmvmpi.f90 | 6 +- src/lib/mpi90/spicmvmpi_I.f90 | 22 +- src/lib/mpi90/sys_chdir.f90 | 10 +- src/lib/mpi90/sys_chdir_I.f90 | 4 +- src/lib/mpi90/sys_getwd.f90 | 8 +- src/lib/mpi90/sys_getwd_I.f90 | 4 +- src/lib/mpi90/sys_mkdir.f90 | 10 +- src/lib/mpi90/sys_mkdir_I.f90 | 4 +- src/tool/Makefile | 49 +- src/tool/lscomp.pl | 1146 +-- src/tool/rasfsplit.f90 | 12 +- src/tool/rcsfblock.f90 | 4 +- src/tool/rcsfmr.f90 | 12 +- src/tool/rcsfratip.f90 | 6 +- src/tool/rcsfsplit.f90 | 30 +- src/tool/rhfs_lsj.f90 | 26 +- src/tool/rlevels.f90 | 24 +- src/tool/rlevelseV.f90 | 26 +- src/tool/rmixaccumulate.f90 | 660 +- src/tool/rmixextract.f90 | 8 +- src/tool/rsave | 0 src/tool/rseqenergy.f90 | 28 +- src/tool/rseqhfs.f90 | 30 +- src/tool/rseqtrans.f90 | 42 +- src/tool/rtabhfs.f90 | 54 +- src/tool/rtablevels.f90 | 36 +- src/tool/rtabtrans1.f90 | 62 +- src/tool/rtabtrans2.f90 | 134 +- src/tool/rtabtransE1.f90 | 890 +- src/tool/rwfnmchfmcdf.f90 | 30 +- src/tool/rwfnplot.f90 | 322 +- src/tool/rwfnrelabel.f90 | 390 +- src/tool/rwfnrotate.f90 | 20 +- src/tool/wfnplot.f90 | 252 +- 1531 files changed, 60181 insertions(+), 60223 deletions(-) mode change 100755 => 100644 src/appl/HF/Makefile mode change 100755 => 100644 src/appl/Makefile mode change 100755 => 100644 src/appl/jj2lsj90/Makefile mode change 100755 => 100644 src/appl/jjgen90/Makefile mode change 100755 => 100644 src/appl/rangular90/cons_C.f90 mode change 100755 => 100644 src/appl/rbiotransform90/Makefile mode change 100755 => 100644 src/appl/rbiotransform90_mpi/Makefile mode change 100755 => 100644 src/appl/rci90/Makefile mode change 100755 => 100644 src/appl/rci90_mpi/Makefile mode change 100755 => 100644 src/appl/rcsfinteract90/Makefile mode change 100755 => 100644 src/appl/rcsfzerofirst90/Makefile mode change 100755 => 100644 src/appl/rcsfzerofirst90/RCSFzerofirst.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/lodcsl_Part.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/lodcsl_Zero.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/lodcsl_Zero_I.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/set_CSF_number.f90 mode change 100755 => 100644 src/appl/rcsfzerofirst90/set_CSF_number_I.f90 mode change 100755 => 100644 src/appl/rhfs90/Makefile mode change 100755 => 100644 src/appl/rmcdhf90/Makefile mode change 100755 => 100644 src/appl/rmcdhf90/lodcsh2GG.f90 mode change 100755 => 100644 src/appl/rmcdhf90/lodcsh2GG_I.f90 mode change 100755 => 100644 src/appl/rmcdhf90_mpi/Makefile mode change 100755 => 100644 src/appl/rmcdhf90_mpi/lodcsh2GG.f90 mode change 100755 => 100644 src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 mode change 100755 => 100644 src/appl/rnucleus90/Makefile mode change 100755 => 100644 src/appl/rtransition90/Makefile mode change 100755 => 100644 src/appl/rtransition90_mpi/Makefile mode change 100755 => 100644 src/appl/rwfnestimate90/Makefile mode change 100755 => 100644 src/appl/sms90/Makefile mode change 100755 => 100644 src/lib/Makefile mode change 100755 => 100644 src/lib/lib9290/Makefile mode change 100755 => 100644 src/lib/libdvd90/Makefile mode change 100755 => 100644 src/lib/libdvd90/Makefile_Ser mode change 100755 => 100644 src/lib/libdvd90/Makefile_mpi mode change 100755 => 100644 src/lib/libmcp90/Makefile mode change 100755 => 100644 src/lib/libmod/Makefile mode change 100755 => 100644 src/lib/libmod/memory_man.f90_PROFILING mode change 100755 => 100644 src/lib/librang90/Makefile mode change 100755 => 100644 src/lib/librang90/ReadMe mode change 100755 => 100644 src/tool/lscomp.pl mode change 100755 => 100644 src/tool/rsave diff --git a/make_environment_gfortran_UBC b/make_environment_gfortran_UBC index e1c5ef506..f8a8e5ab0 100755 --- a/make_environment_gfortran_UBC +++ b/make_environment_gfortran_UBC @@ -4,7 +4,7 @@ # ------------------------------------------------------------------------------------------------------------------------------------- # # Define the following global variables according to your environment and -# source this script or add these definitions to your terminal configuration +# source this script or add these definitions to your terminal configuration # file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. # # Current version: Linux, gfortran gcc version 5.4.0 @@ -16,7 +16,7 @@ # ----------------------------------------------------------------------------------------------------------------- # Set up main flags # ----------------------------------------------------------------------------------------------------------------- -export FC=gfortran # Fortran compiler +export FC=gfortran # Fortran compiler export FC_FLAGS="-O2 -fno-automatic " # Serial code compiler flags export FC_LD=" " # Serial linker flags export GRASP="${PWD}" # Location of the 2018 root directory diff --git a/make_environment_ifort_CC b/make_environment_ifort_CC index 72dbd57f4..81d562d68 100755 --- a/make_environment_ifort_CC +++ b/make_environment_ifort_CC @@ -4,7 +4,7 @@ # -------------------------------------------------------------------------------------- # # Define the following global variables according to your environment and -# source this script or add these definitions to your terminal configuration +# source this script or add these definitions to your terminal configuration # file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. # # Current version: Linux, gfortran gcc version 4.8.2 @@ -16,7 +16,7 @@ # -------------------------------------------------------------------------------------- # Set up main flags # -------------------------------------------------------------------------------------- -export FC=ifort # Fortran compiler +export FC=ifort # Fortran compiler export FC_FLAGS="-O2 -save " # Serial code compiler flags #export FC_FLAGS="-O0 -check all" # Options for check for runtime errors export FC_LD="-mkl=sequential" # Serial linker flags diff --git a/src/Makefile b/src/Makefile index 7cff1fc99..85215d314 100644 --- a/src/Makefile +++ b/src/Makefile @@ -24,4 +24,3 @@ clean : make clean; \ cd .. ; \ done - diff --git a/src/appl/HF/HF.f90 b/src/appl/HF/HF.f90 index 30e157c37..72004195c 100644 --- a/src/appl/HF/HF.f90 +++ b/src/appl/HF/HF.f90 @@ -16,9 +16,9 @@ ! i) Named COMMON were replacd by a module ! ii) INTERFACE modules are used to check calling sequences ! iii) Many obsolete features were removed. -! +! ! Incomplete translations and the removal of EQUIVALENCE and DATA -! statements were dealt with by the author. +! statements were dealt with by the author. ! ------------------------------------------------------------------ ! ! All comments in the program listing assume the radial function P @@ -49,625 +49,625 @@ ! M O D U L E S ! ------------------------------------------------------------------ ! Defining data types - module vast_kind_param - integer, parameter :: byte_log = selected_int_kind(2) - integer, parameter :: short_log = selected_int_kind(4) - integer, parameter :: long_log = selected_int_kind(18) - integer, parameter :: byte = selected_int_kind(2) - integer, parameter :: short = selected_int_kind(4) - integer, parameter :: long = selected_int_kind(18) - integer, parameter :: double = selected_real_kind(13) - integer, parameter :: extended = selected_real_kind(30) - integer, parameter :: double_ext = selected_real_kind(50) + module vast_kind_param + integer, parameter :: byte_log = selected_int_kind(2) + integer, parameter :: short_log = selected_int_kind(4) + integer, parameter :: long_log = selected_int_kind(18) + integer, parameter :: byte = selected_int_kind(2) + integer, parameter :: short = selected_int_kind(4) + integer, parameter :: long = selected_int_kind(18) + integer, parameter :: double = selected_real_kind(13) + integer, parameter :: extended = selected_real_kind(30) + integer, parameter :: double_ext = selected_real_kind(50) integer, parameter :: dble_complex = selected_real_kind(13) - integer, parameter :: ext_complex = selected_real_kind(30) - end module vast_kind_param + integer, parameter :: ext_complex = selected_real_kind(30) + end module vast_kind_param ! ------------------------------------------------------------------ -! C O M M O N M O D U L E S +! C O M M O N M O D U L E S ! ------------------------------------------------------------------ - MODULE blume_C - USE vast_kind_param, ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(4) :: COEFN2, COEFNK, COEFVK - END MODULE blume_C - MODULE coeff_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, DIMENSION(5,5) :: IJPTR - REAL(DOUBLE), DIMENSION(200) :: COEF - END MODULE coeff_C - MODULE DE_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, PARAMETER :: NWFD = 20, NOD = 220 - INTEGER, DIMENSION(NWFD) :: IND + MODULE blume_C + USE vast_kind_param, ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(4) :: COEFN2, COEFNK, COEFVK + END MODULE blume_C + MODULE coeff_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, DIMENSION(5,5) :: IJPTR + REAL(DOUBLE), DIMENSION(200) :: COEF + END MODULE coeff_C + MODULE DE_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, PARAMETER :: NWFD = 20, NOD = 220 + INTEGER, DIMENSION(NWFD) :: IND INTEGER :: M, NODE, MK, KK, NJ REAL(DOUBLE), DIMENSION(NOD) :: P2, HQ, XX REAL(DOUBLE):: V, B4, CN, C, XY, XP, AZZ, PP, FN, EM, FM, EU, FU,DELTAE - END MODULE de_C - MODULE eav_C - USE vast_kind_param, ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(10) :: CCA - REAL(DOUBLE), DIMENSION(35) :: CCB - END MODULE eav_C - MODULE estP_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, PARAMETER :: NWFD = 20 + END MODULE de_C + MODULE eav_C + USE vast_kind_param, ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(10) :: CCA + REAL(DOUBLE), DIMENSION(35) :: CCB + END MODULE eav_C + MODULE estP_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, PARAMETER :: NWFD = 20 INTEGER, DIMENSION(NWFD) :: IND REAL(DOUBLE), DIMENSION(NWFD) :: ZZ END MODULE estP_C - MODULE fact_C - USE vast_kind_param, ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(100) :: GAM - END MODULE fact_C - MODULE inout_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER :: IUF, OUF - END MODULE inout_C - MODULE label_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, PARAMETER :: NWFD = 20 - CHARACTER, DIMENSION(NWFD) :: EL*3 - CHARACTER :: CONFIG*50, ATOM*6, TERM*6 - END MODULE label_C - MODULE param_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER :: NO, ND, NWF, NP, NCFG, IB, IC, ID, NSCF, NCLOSD + MODULE fact_C + USE vast_kind_param, ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(100) :: GAM + END MODULE fact_C + MODULE inout_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER :: IUF, OUF + END MODULE inout_C + MODULE label_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, PARAMETER :: NWFD = 20 + CHARACTER, DIMENSION(NWFD) :: EL*3 + CHARACTER :: CONFIG*50, ATOM*6, TERM*6 + END MODULE label_C + MODULE param_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER :: NO, ND, NWF, NP, NCFG, IB, IC, ID, NSCF, NCLOSD REAL(DOUBLE) :: H, H1, H3, CH, EH, RHO, Z, TOL, D0, D1, D2, D3, D4, D5, & - D6, D8, D10, D12, D16, D30, FINE - END MODULE param_C - MODULE radial_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, PARAMETER :: NOD = 220 - INTEGER, PARAMETER :: NWFD = 20 - INTEGER, DIMENSION(NWFD) :: L, MAX, N - REAL(DOUBLE), DIMENSION(NOD) :: R, RR, R2 - REAL(DOUBLE), DIMENSION(NOD,NWFD) :: P + D6, D8, D10, D12, D16, D30, FINE + END MODULE param_C + MODULE radial_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, PARAMETER :: NOD = 220 + INTEGER, PARAMETER :: NWFD = 20 + INTEGER, DIMENSION(NWFD) :: L, MAX, N + REAL(DOUBLE), DIMENSION(NOD) :: R, RR, R2 + REAL(DOUBLE), DIMENSION(NOD,NWFD) :: P REAL(DOUBLE), DIMENSION(NOD) :: YK, YR, X - REAL(DOUBLE), DIMENSION(NWFD) :: AZ - END MODULE radial_C - MODULE test_C - USE vast_kind_param, ONLY: DOUBLE - LOGICAL :: FAIL, OMIT, REL, ALL, TRACE - END MODULE test_C - MODULE wave_C - USE vast_kind_param, ONLY: DOUBLE - INTEGER, PARAMETER :: NOD = 220 - INTEGER, PARAMETER :: NWFD = 20 - INTEGER, DIMENSION(NWFD) :: METH, IORD - INTEGER :: IPR + REAL(DOUBLE), DIMENSION(NWFD) :: AZ + END MODULE radial_C + MODULE test_C + USE vast_kind_param, ONLY: DOUBLE + LOGICAL :: FAIL, OMIT, REL, ALL, TRACE + END MODULE test_C + MODULE wave_C + USE vast_kind_param, ONLY: DOUBLE + INTEGER, PARAMETER :: NOD = 220 + INTEGER, PARAMETER :: NWFD = 20 + INTEGER, DIMENSION(NWFD) :: METH, IORD + INTEGER :: IPR REAL(DOUBLE), DIMENSION(NOD) :: PDE - REAL(DOUBLE), DIMENSION(NWFD) :: EK - REAL(DOUBLE), DIMENSION(NWFD,NWFD) :: E - REAL(DOUBLE), DIMENSION(NWFD) :: SUM, S, DPM, ACC - REAL(DOUBLE) :: ED, AZD - END MODULE wave_C + REAL(DOUBLE), DIMENSION(NWFD) :: EK + REAL(DOUBLE), DIMENSION(NWFD,NWFD) :: E + REAL(DOUBLE), DIMENSION(NWFD) :: SUM, S, DPM, ACC + REAL(DOUBLE) :: ED, AZD + END MODULE wave_C ! ------------------------------------------------------------------ ! I N T E R F A C E M O D U L E S ! ------------------------------------------------------------------ - MODULE a_I + MODULE a_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION a (I, J, K) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, K - END FUNCTION - END INTERFACE - END MODULE - MODULE add_I + REAL(KIND(0.0D0)) FUNCTION a (I, J, K) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, K + END FUNCTION + END INTERFACE + END MODULE + MODULE add_I INTERFACE - SUBROUTINE add (C, K, I, J, FIRST) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - REAL(DOUBLE), INTENT(IN) :: C - INTEGER, INTENT(IN) :: K, I, J - LOGICAL, INTENT(IN) :: FIRST - END SUBROUTINE - END INTERFACE - END MODULE - MODULE array_I + SUBROUTINE add (C, K, I, J, FIRST) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + REAL(DOUBLE), INTENT(IN) :: C + INTEGER, INTENT(IN) :: K, I, J + LOGICAL, INTENT(IN) :: FIRST + END SUBROUTINE + END INTERFACE + END MODULE + MODULE array_I INTERFACE - SUBROUTINE array - END SUBROUTINE - END INTERFACE - END MODULE - MODULE b_I + SUBROUTINE array + END SUBROUTINE + END INTERFACE + END MODULE + MODULE b_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION b (I, J, K) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, K - END FUNCTION - END INTERFACE - END MODULE - MODULE bwint_I + REAL(KIND(0.0D0)) FUNCTION b (I, J, K) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, K + END FUNCTION + END INTERFACE + END MODULE + MODULE bwint_I INTERFACE - SUBROUTINE bwint (LC, LO) - INTEGER, INTENT(IN) :: LC, LO - END SUBROUTINE - END INTERFACE - END MODULE - MODULE bwzeta_I + SUBROUTINE bwint (LC, LO) + INTEGER, INTENT(IN) :: LC, LO + END SUBROUTINE + END INTERFACE + END MODULE + MODULE bwzeta_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION bwzeta (I1) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I1 - END FUNCTION - END INTERFACE - END MODULE - MODULE ca_I + REAL(KIND(0.0D0)) FUNCTION bwzeta (I1) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I1 + END FUNCTION + END INTERFACE + END MODULE + MODULE ca_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION ca (L, K) - INTEGER, INTENT(IN) :: L, K - END FUNCTION - END INTERFACE - END MODULE - MODULE cb_I + REAL(KIND(0.0D0)) FUNCTION ca (L, K) + INTEGER, INTENT(IN) :: L, K + END FUNCTION + END INTERFACE + END MODULE + MODULE cb_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION cb (L, LP, K) - INTEGER, INTENT(IN) :: L, LP, K - END FUNCTION - END INTERFACE - END MODULE - MODULE data_I + REAL(KIND(0.0D0)) FUNCTION cb (L, LP, K) + INTEGER, INTENT(IN) :: L, LP, K + END FUNCTION + END INTERFACE + END MODULE + MODULE data_I INTERFACE - SUBROUTINE data - END SUBROUTINE - END INTERFACE - END MODULE - MODULE de_I + SUBROUTINE data + END SUBROUTINE + END INTERFACE + END MODULE + MODULE de_I INTERFACE - SUBROUTINE de (I1) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I1 - END SUBROUTINE - END INTERFACE - END MODULE - MODULE dev_I + SUBROUTINE de (I1) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I1 + END SUBROUTINE + END INTERFACE + END MODULE + MODULE dev_I INTERFACE - SUBROUTINE dev (IEL, L, Q, I, DONE) - USE vast_kind_param,ONLY: DOUBLE - INTEGER :: IEL - INTEGER, INTENT(IN) :: L - REAL(DOUBLE), INTENT(IN) :: Q - INTEGER, INTENT(INOUT) :: I - LOGICAL, INTENT(OUT) :: DONE - END SUBROUTINE - END INTERFACE - END MODULE - MODULE dyk_I + SUBROUTINE dev (IEL, L, Q, I, DONE) + USE vast_kind_param,ONLY: DOUBLE + INTEGER :: IEL + INTEGER, INTENT(IN) :: L + REAL(DOUBLE), INTENT(IN) :: Q + INTEGER, INTENT(INOUT) :: I + LOGICAL, INTENT(OUT) :: DONE + END SUBROUTINE + END INTERFACE + END MODULE + MODULE dyk_I INTERFACE - SUBROUTINE dyk (I, J, K) - INTEGER NODi, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, K - END SUBROUTINE - END INTERFACE - END MODULE - MODULE ekin_I + SUBROUTINE dyk (I, J, K) + INTEGER NODi, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, K + END SUBROUTINE + END INTERFACE + END MODULE + MODULE ekin_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION ekin (I, II, REL) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER :: I - INTEGER, INTENT(IN) :: II - LOGICAL :: REL - END FUNCTION - END INTERFACE - END MODULE - MODULE energy_I + REAL(KIND(0.0D0)) FUNCTION ekin (I, II, REL) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER :: I + INTEGER, INTENT(IN) :: II + LOGICAL :: REL + END FUNCTION + END INTERFACE + END MODULE + MODULE energy_I INTERFACE - SUBROUTINE energy (ETOTAL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - REAL(DOUBLE), INTENT(OUT) :: ETOTAL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE enexpr_I + SUBROUTINE energy (ETOTAL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + REAL(DOUBLE), INTENT(OUT) :: ETOTAL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE enexpr_I INTERFACE - SUBROUTINE enexpr (TERM, DONE) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - CHARACTER (LEN = 6), INTENT(IN) :: TERM - LOGICAL, INTENT(OUT) :: DONE - END SUBROUTINE - END INTERFACE - END MODULE - MODULE eptr_I + SUBROUTINE enexpr (TERM, DONE) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + CHARACTER (LEN = 6), INTENT(IN) :: TERM + LOGICAL, INTENT(OUT) :: DONE + END SUBROUTINE + END INTERFACE + END MODULE + MODULE eptr_I INTERFACE - SUBROUTINE eptr (EL, ELSYMB, IEL, J1) - CHARACTER (LEN = 3), DIMENSION(*), INTENT(IN) :: EL - CHARACTER (LEN = 3), INTENT(IN) :: ELSYMB - INTEGER, INTENT(OUT) :: IEL, J1 - END SUBROUTINE - END INTERFACE - END MODULE - MODULE factrl_I + SUBROUTINE eptr (EL, ELSYMB, IEL, J1) + CHARACTER (LEN = 3), DIMENSION(*), INTENT(IN) :: EL + CHARACTER (LEN = 3), INTENT(IN) :: ELSYMB + INTEGER, INTENT(OUT) :: IEL, J1 + END SUBROUTINE + END INTERFACE + END MODULE + MODULE factrl_I INTERFACE - SUBROUTINE factrl (NFACT) - INTEGER, INTENT(IN) :: NFACT - END SUBROUTINE - END INTERFACE - END MODULE - MODULE fk_I + SUBROUTINE factrl (NFACT) + INTEGER, INTENT(IN) :: NFACT + END SUBROUTINE + END INTERFACE + END MODULE + MODULE fk_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION fk (I, J, K, REL) - INTEGER :: I, J, K - LOGICAL :: REL - END FUNCTION - END INTERFACE - END MODULE - MODULE gk_I + REAL(KIND(0.0D0)) FUNCTION fk (I, J, K, REL) + INTEGER :: I, J, K + LOGICAL :: REL + END FUNCTION + END INTERFACE + END MODULE + MODULE gk_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION gk (I, J, K, REL) - INTEGER :: I, J, K - LOGICAL :: REL - END FUNCTION - END INTERFACE - END MODULE - MODULE grange_I + REAL(KIND(0.0D0)) FUNCTION gk (I, J, K, REL) + INTEGER :: I, J, K + LOGICAL :: REL + END FUNCTION + END INTERFACE + END MODULE + MODULE grange_I INTERFACE - SUBROUTINE grange - END SUBROUTINE - END INTERFACE - END MODULE - MODULE help_I + SUBROUTINE grange + END SUBROUTINE + END INTERFACE + END MODULE + MODULE help_I INTERFACE - SUBROUTINE help (CASE) - INTEGER, INTENT(IN) :: CASE - END SUBROUTINE - END INTERFACE - END MODULE - MODULE hl_I + SUBROUTINE help (CASE) + INTEGER, INTENT(IN) :: CASE + END SUBROUTINE + END INTERFACE + END MODULE + MODULE hl_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION hl (EL, I, J, REL) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - CHARACTER (LEN = 3), DIMENSION(*), INTENT(IN) :: EL - INTEGER, INTENT(IN) :: I, J - LOGICAL, INTENT(IN) :: REL - END FUNCTION - END INTERFACE - END MODULE - MODULE hnorm_I + REAL(KIND(0.0D0)) FUNCTION hl (EL, I, J, REL) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + CHARACTER (LEN = 3), DIMENSION(*), INTENT(IN) :: EL + INTEGER, INTENT(IN) :: I, J + LOGICAL, INTENT(IN) :: REL + END FUNCTION + END INTERFACE + END MODULE + MODULE hnorm_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION hnorm (N, L, ZZ) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N, L - REAL(DOUBLE), INTENT(IN) :: ZZ - END FUNCTION - END INTERFACE - END MODULE - MODULE hwf_I + REAL(KIND(0.0D0)) FUNCTION hnorm (N, L, ZZ) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N, L + REAL(DOUBLE), INTENT(IN) :: ZZ + END FUNCTION + END INTERFACE + END MODULE + MODULE hwf_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION hwf (N, L, ZZ, R) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N, L - REAL(DOUBLE), INTENT(IN) :: ZZ, R - END FUNCTION - END INTERFACE - END MODULE - MODULE init_I + REAL(KIND(0.0D0)) FUNCTION hwf (N, L, ZZ, R) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N, L + REAL(DOUBLE), INTENT(IN) :: ZZ, R + END FUNCTION + END INTERFACE + END MODULE + MODULE init_I INTERFACE - SUBROUTINE init - END SUBROUTINE - END INTERFACE - END MODULE - MODULE la_I + SUBROUTINE init + END SUBROUTINE + END INTERFACE + END MODULE + MODULE la_I INTERFACE - INTEGER FUNCTION la (A) - character (LEN = 1), INTENT(IN) :: A - END FUNCTION - END INTERFACE - END MODULE - MODULE looktm_I + INTEGER FUNCTION la (A) + character (LEN = 1), INTENT(IN) :: A + END FUNCTION + END INTERFACE + END MODULE + MODULE looktm_I INTERFACE - SUBROUTINE looktm (L, SL, SEN, Q, IP, NSL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: L - CHARACTER (LEN = 2), INTENT(IN) :: SL - CHARACTER (LEN = 1), INTENT(IN) :: SEN - REAL(DOUBLE), INTENT(IN) :: Q - INTEGER, INTENT(OUT) :: IP - INTEGER, INTENT(OUT) :: NSL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE lookup_I + SUBROUTINE looktm (L, SL, SEN, Q, IP, NSL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: L + CHARACTER (LEN = 2), INTENT(IN) :: SL + CHARACTER (LEN = 1), INTENT(IN) :: SEN + REAL(DOUBLE), INTENT(IN) :: Q + INTEGER, INTENT(OUT) :: IP + INTEGER, INTENT(OUT) :: NSL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE lookup_I INTERFACE - SUBROUTINE lookup (TAB, P1, P2, IND, NO, KEY) - INTEGER, DIMENSION(*), INTENT(IN) :: TAB - INTEGER, INTENT(IN) :: P1, P2 - INTEGER, INTENT(OUT) :: IND - INTEGER, INTENT(INOUT) :: NO - INTEGER, INTENT(IN) :: KEY - END SUBROUTINE - END INTERFACE - END MODULE - MODULE lval_I + SUBROUTINE lookup (TAB, P1, P2, IND, NO, KEY) + INTEGER, DIMENSION(*), INTENT(IN) :: TAB + INTEGER, INTENT(IN) :: P1, P2 + INTEGER, INTENT(OUT) :: IND + INTEGER, INTENT(INOUT) :: NO + INTEGER, INTENT(IN) :: KEY + END SUBROUTINE + END INTERFACE + END MODULE + MODULE lval_I INTERFACE - INTEGER FUNCTION lval (SYMBOL) - CHARACTER (LEN = 1), INTENT(IN) :: SYMBOL - END FUNCTION - END INTERFACE - END MODULE - MODULE menu_I + INTEGER FUNCTION lval (SYMBOL) + CHARACTER (LEN = 1), INTENT(IN) :: SYMBOL + END FUNCTION + END INTERFACE + END MODULE + MODULE menu_I INTERFACE - SUBROUTINE menu - END SUBROUTINE - END INTERFACE - END MODULE - MODULE methd1_I + SUBROUTINE menu + END SUBROUTINE + END INTERFACE + END MODULE + MODULE methd1_I INTERFACE - SUBROUTINE methd1 (I) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I - END SUBROUTINE - END INTERFACE - END MODULE - MODULE nmrvs_I + SUBROUTINE methd1 (I) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I + END SUBROUTINE + END INTERFACE + END MODULE + MODULE nmrvs_I INTERFACE - SUBROUTINE nmrvs (NJ, DELTA, MM, PDE, F) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: NJ - REAL(DOUBLE), INTENT(OUT) :: DELTA - INTEGER, INTENT(OUT) :: MM - REAL(DOUBLE), DIMENSION(NOD), INTENT(INOUT) :: PDE - REAL(DOUBLE), DIMENSION(NOD), INTENT(IN) :: F - END SUBROUTINE - END INTERFACE - END MODULE - MODULE nodec_I + SUBROUTINE nmrvs (NJ, DELTA, MM, PDE, F) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: NJ + REAL(DOUBLE), INTENT(OUT) :: DELTA + INTEGER, INTENT(OUT) :: MM + REAL(DOUBLE), DIMENSION(NOD), INTENT(INOUT) :: PDE + REAL(DOUBLE), DIMENSION(NOD), INTENT(IN) :: F + END SUBROUTINE + END INTERFACE + END MODULE + MODULE nodec_I INTERFACE - INTEGER FUNCTION nodec (M) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(INOUT) :: M - END FUNCTION - END INTERFACE - END MODULE - MODULE orthog_I + INTEGER FUNCTION nodec (M) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(INOUT) :: M + END FUNCTION + END INTERFACE + END MODULE + MODULE orthog_I INTERFACE - SUBROUTINE orthog - END SUBROUTINE - END INTERFACE - END MODULE - MODULE output_I + SUBROUTINE orthog + END SUBROUTINE + END INTERFACE + END MODULE + MODULE output_I INTERFACE - SUBROUTINE output (PRINT) - INTEGER NODi, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - LOGICAL, INTENT(IN) :: PRINT - END SUBROUTINE - END INTERFACE - END MODULE - MODULE potl_I + SUBROUTINE output (PRINT) + INTEGER NODi, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + LOGICAL, INTENT(IN) :: PRINT + END SUBROUTINE + END INTERFACE + END MODULE + MODULE potl_I INTERFACE - SUBROUTINE potl (I, REL) - INTEGER NODi, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I - LOGICAL :: REL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE quad_I + SUBROUTINE potl (I, REL) + INTEGER NODi, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I + LOGICAL :: REL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE quad_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION quad (I, M, F, G) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, M - REAL(DOUBLE), DIMENSION(NOD), INTENT(IN) :: F, G - END FUNCTION - END INTERFACE - END MODULE - MODULE quadr_I + REAL(KIND(0.0D0)) FUNCTION quad (I, M, F, G) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, M + REAL(DOUBLE), DIMENSION(NOD), INTENT(IN) :: F, G + END FUNCTION + END INTERFACE + END MODULE + MODULE quadr_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION quadr (I, J, KK) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, KK - END FUNCTION - END INTERFACE - END MODULE - MODULE quads_I + REAL(KIND(0.0D0)) FUNCTION quadr (I, J, KK) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, KK + END FUNCTION + END INTERFACE + END MODULE + MODULE quads_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION quads (I, J, KK) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, KK - END FUNCTION - END INTERFACE - END MODULE - MODULE reform_I + REAL(KIND(0.0D0)) FUNCTION quads (I, J, KK) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, KK + END FUNCTION + END INTERFACE + END MODULE + MODULE reform_I INTERFACE - SUBROUTINE reform (STR1, STR2) - CHARACTER (LEN = 50), INTENT(IN) :: STR1 - CHARACTER (LEN = 50), INTENT(OUT) :: STR2 - END SUBROUTINE - END INTERFACE - END MODULE - MODULE reord_I + SUBROUTINE reform (STR1, STR2) + CHARACTER (LEN = 50), INTENT(IN) :: STR1 + CHARACTER (LEN = 50), INTENT(OUT) :: STR2 + END SUBROUTINE + END INTERFACE + END MODULE + MODULE reord_I INTERFACE - SUBROUTINE reord (OF, ELC, NWF, IERR) - CHARACTER (LEN = 3), DIMENSION(:), INTENT(INOUT) :: OF - CHARACTER (LEN = 3), INTENT(IN) :: ELC - INTEGER, INTENT(IN) :: NWF - INTEGER, INTENT(OUT) :: IERR - END SUBROUTINE - END INTERFACE - END MODULE - MODULE rk_I + SUBROUTINE reord (OF, ELC, NWF, IERR) + CHARACTER (LEN = 3), DIMENSION(:), INTENT(INOUT) :: OF + CHARACTER (LEN = 3), INTENT(IN) :: ELC + INTEGER, INTENT(IN) :: NWF + INTEGER, INTENT(OUT) :: IERR + END SUBROUTINE + END INTERFACE + END MODULE + MODULE rk_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION rk (I, J, II, JJ, K, REL) - INTEGER :: I, J, II, JJ, K - LOGICAL :: REL - END FUNCTION - END INTERFACE - END MODULE - MODULE rlshft_I + REAL(KIND(0.0D0)) FUNCTION rk (I, J, II, JJ, K, REL) + INTEGER :: I, J, II, JJ, K + LOGICAL :: REL + END FUNCTION + END INTERFACE + END MODULE + MODULE rlshft_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION rlshft (I1, I2) - INTEGER NODi, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I1, I2 - END FUNCTION - END INTERFACE - END MODULE - MODULE rme_I + REAL(KIND(0.0D0)) FUNCTION rlshft (I1, I2) + INTEGER NODi, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I1, I2 + END FUNCTION + END INTERFACE + END MODULE + MODULE rme_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION rme (L, LP, K) + REAL(KIND(0.0D0)) FUNCTION rme (L, LP, K) INTEGER, INTENT(IN) :: L, LP, K - END FUNCTION - END INTERFACE - END MODULE - MODULE rotate_I + END FUNCTION + END INTERFACE + END MODULE + MODULE rotate_I INTERFACE - SUBROUTINE rotate (I, J) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J - END SUBROUTINE - END INTERFACE - END MODULE - MODULE scale_I + SUBROUTINE rotate (I, J) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J + END SUBROUTINE + END INTERFACE + END MODULE + MODULE scale_I INTERFACE - SUBROUTINE scale (ZZ) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD - PARAMETER (NOD = 220) - INTEGER NWFD - PARAMETER (NWFD = 20) - REAL(DOUBLE), INTENT(IN) :: ZZ - END SUBROUTINE - END INTERFACE - END MODULE - MODULE scf_I + SUBROUTINE scale (ZZ) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD + PARAMETER (NOD = 220) + INTEGER NWFD + PARAMETER (NWFD = 20) + REAL(DOUBLE), INTENT(IN) :: ZZ + END SUBROUTINE + END INTERFACE + END MODULE + MODULE scf_I INTERFACE - SUBROUTINE scf (ETOTAL, SCFTOL, EREL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - REAL(DOUBLE), INTENT(OUT) :: ETOTAL - REAL(DOUBLE), INTENT(IN) :: SCFTOL - REAL(DOUBLE), INTENT(OUT) :: EREL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE search_I + SUBROUTINE scf (ETOTAL, SCFTOL, EREL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + REAL(DOUBLE), INTENT(OUT) :: ETOTAL + REAL(DOUBLE), INTENT(IN) :: SCFTOL + REAL(DOUBLE), INTENT(OUT) :: EREL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE search_I INTERFACE - SUBROUTINE search (NJ, I) - INTEGER NODi, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(OUT) :: NJ - INTEGER, INTENT(IN) :: I - END SUBROUTINE - END INTERFACE - END MODULE - MODULE sn_I + SUBROUTINE search (NJ, I) + INTEGER NODi, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(OUT) :: NJ + INTEGER, INTENT(IN) :: I + END SUBROUTINE + END INTERFACE + END MODULE + MODULE sn_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION sn (I, J, II, JJ, K) - INTEGER :: I, J, II, JJ, K - END FUNCTION - END INTERFACE - END MODULE - MODULE solve_I + REAL(KIND(0.0D0)) FUNCTION sn (I, J, II, JJ, K) + INTEGER :: I, J, II, JJ, K + END FUNCTION + END INTERFACE + END MODULE + MODULE solve_I INTERFACE - SUBROUTINE solve (I, FIRST, REL) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I - LOGICAL, INTENT(IN) :: FIRST - LOGICAL :: REL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE summry_I + SUBROUTINE solve (I, FIRST, REL) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I + LOGICAL, INTENT(IN) :: FIRST + LOGICAL :: REL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE summry_I INTERFACE - SUBROUTINE summry (ET, EREL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - REAL(DOUBLE), INTENT(IN) :: ET - REAL(DOUBLE), INTENT(IN) :: EREL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE vk_I + SUBROUTINE summry (ET, EREL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + REAL(DOUBLE), INTENT(IN) :: ET + REAL(DOUBLE), INTENT(IN) :: EREL + END SUBROUTINE + END INTERFACE + END MODULE + MODULE vk_I INTERFACE - REAL(KIND(0.0D0)) FUNCTION vk (I, J, II, JJ, K) - INTEGER :: I, J, II, JJ, K - END FUNCTION - END INTERFACE - END MODULE - MODULE wavefn_I + REAL(KIND(0.0D0)) FUNCTION vk (I, J, II, JJ, K) + INTEGER :: I, J, II, JJ, K + END FUNCTION + END INTERFACE + END MODULE + MODULE wavefn_I INTERFACE - SUBROUTINE wavefn - END SUBROUTINE - END INTERFACE - END MODULE - MODULE xch_I + SUBROUTINE wavefn + END SUBROUTINE + END INTERFACE + END MODULE + MODULE xch_I INTERFACE - SUBROUTINE xch (I, IOPT) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: IOPT - END SUBROUTINE - END INTERFACE - END MODULE - MODULE ykf_I + SUBROUTINE xch (I, IOPT) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: IOPT + END SUBROUTINE + END INTERFACE + END MODULE + MODULE ykf_I INTERFACE - SUBROUTINE ykf (I, J, K, REL) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) + SUBROUTINE ykf (I, J, K, REL) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) INTEGER, INTENT(IN) :: I, J, K LOGICAL, INTENT(IN) :: REL - END SUBROUTINE - END INTERFACE - END MODULE - MODULE zk_I + END SUBROUTINE + END INTERFACE + END MODULE + MODULE zk_I INTERFACE - SUBROUTINE zk (I, J, K) - INTEGER NOD, NWFD - PARAMETER (NOD = 220) - PARAMETER (NWFD = 20) - INTEGER, INTENT(IN) :: I, J, K - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE zk (I, J, K) + INTEGER NOD, NWFD + PARAMETER (NOD = 220) + PARAMETER (NWFD = 20) + INTEGER, INTENT(IN) :: I, J, K + END SUBROUTINE + END INTERFACE + END MODULE ! ------------------------------------------------------------------ ! M A I N P R O G R A M ! ------------------------------------------------------------------ @@ -680,198 +680,198 @@ SUBROUTINE zk (I, J, K) ! others are obtained by scaling the previous results using the ! scaling of Sec. (7-2). ! - PROGRAM MAIN + PROGRAM MAIN !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE LABEL_C - USE WAVE_C, ONLY: E, DPM, ACC, NOD - USE PARAM_C - USE INOUT_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE LABEL_C + USE WAVE_C, ONLY: E, DPM, ACC, NOD + USE PARAM_C + USE INOUT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE init_I - USE data_I - USE help_I - USE scf_I - USE output_I - USE summry_I - USE menu_I - USE scale_I - USE orthog_I + USE init_I + USE data_I + USE help_I + USE scf_I + USE output_I + USE summry_I + USE menu_I + USE scale_I + USE orthog_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J - REAL(DOUBLE) :: SCFTOL, ETOTAL, EREL, ZZ - LOGICAL :: PRINT, STRONG, OLD - CHARACTER(LEN=1) :: ANS, ASTER = '*' + INTEGER :: I, J + REAL(DOUBLE) :: SCFTOL, ETOTAL, EREL, ZZ + LOGICAL :: PRINT, STRONG, OLD + CHARACTER(LEN=1) :: ANS, ASTER = '*' !----------------------------------------------- ! ! ***** WRITE OUT HEADER ! - WRITE (6, 9) + WRITE (6, 9) 9 FORMAT(/,/,/,/,/,/,/,22X,'=============================',/,22X,& - ' H A R T R E E - F O C K . 86',/,22X,'=============================') + ' H A R T R E E - F O C K . 86',/,22X,'=============================') ! ! ***** WRITE OUT DIMENSION INFORMATION ! - WRITE (6, 99) 'NWF', NWFD, 'NO', NOD + WRITE (6, 99) 'NWF', NWFD, 'NO', NOD 99 FORMAT(/,/,15X,'THE DIMENSIONS FOR THE CURRENT VERSION ARE:'/,13X,2(10X,2& - (A6,'=',I3,4X),/),/) + (A6,'=',I3,4X),/),/) ! ! ***** INITIALIZE ! - CALL INIT + CALL INIT ! ! ***** SET UNIT NUMBERS AND OPEN FILES ! - WRITE (6, '(2/A/A,2/)') ' START OF CASE', ' =============' - INQUIRE(FILE='wfn.inp', EXIST=OLD) - IF (OLD) THEN - IUF = 21 + WRITE (6, '(2/A/A,2/)') ' START OF CASE', ' =============' + INQUIRE(FILE='wfn.inp', EXIST=OLD) + IF (OLD) THEN + IUF = 21 OPEN(UNIT=IUF, FILE='wfn.inp', STATUS='OLD', FORM='UNFORMATTED', & - POSITION='asis') - ELSE - IUF = 0 - ENDIF - OUF = 31 + POSITION='asis') + ELSE + IUF = 0 + ENDIF + OUF = 31 OPEN(UNIT=OUF, FILE='wfn.out', STATUS='UNKNOWN', FORM='UNFORMATTED', & - POSITION='asis') - OPEN(UNIT=3, FILE='hf.log', STATUS='UNKNOWN', POSITION='asis') + POSITION='asis') + OPEN(UNIT=3, FILE='hf.log', STATUS='UNKNOWN', POSITION='asis') ! - FAIL = .FALSE. - DPM(:NWFD) = D10 - E(:NWFD,:NWFD) = D0 + FAIL = .FALSE. + DPM(:NWFD) = D10 + E(:NWFD,:NWFD) = D0 ! ! ***** DETERMINE DATA ABOUT THE PROBLEM ! - CALL DATA + CALL DATA ! ! ***** SET PARAMETERS TO THEIR DEFAULT VALUE ! - 13 CONTINUE + 13 CONTINUE PRINT = .FALSE. ! plot.dat is generated when PRINT = .TRUE. PRINT = .TRUE. ! plot.dat is generated when PRINT = .TRUE. - SCFTOL = 1.D-8 - NSCF = 12 - IC = 2 + (NWF + 1 - IB)/4 + SCFTOL = 1.D-8 + NSCF = 12 + IC = 2 + (NWF + 1 - IB)/4 TRACE = .FALSE. !! Set to .TRUE. if tracing is desired. - IF (IB <= NWF) THEN - WRITE (0, '(/A)') ' Default values for remaining parameters? (Y/N/H) ' + IF (IB <= NWF) THEN + WRITE (0, '(/A)') ' Default values for remaining parameters? (Y/N/H) ' READ(5,'(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (4) - GO TO 13 - ENDIF - IF (ANS/='Y' .AND. ANS/='y') THEN + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (4) + GO TO 13 + ENDIF + IF (ANS/='Y' .AND. ANS/='y') THEN ! ! ***** ADDITIONAL PARAMETERS ! - 50 CONTINUE - WRITE (0, '(/A)') ' Default values (NO,STRONG) ? (Y/N/H) ' - READ (5, '(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (3) - GO TO 50 - ENDIF - IF (ANS/='Y' .AND. ANS/='y') THEN - WRITE (0, *) ' Enter values in FORMAT(I3,1X,L1) ' - READ (5, '(I3,1X,L1)') NO, STRONG - IF (NO > NOD) THEN + 50 CONTINUE + WRITE (0, '(/A)') ' Default values (NO,STRONG) ? (Y/N/H) ' + READ (5, '(A)') ANS + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (3) + GO TO 50 + ENDIF + IF (ANS/='Y' .AND. ANS/='y') THEN + WRITE (0, *) ' Enter values in FORMAT(I3,1X,L1) ' + READ (5, '(I3,1X,L1)') NO, STRONG + IF (NO > NOD) THEN WRITE (0, '(A,A,I4)') ' TOO MANY POINTS: the allowed', & - ' MAXIMUM is ', NOD - GO TO 50 - ENDIF - ND = NO - 2 - OMIT = .NOT.STRONG - ENDIF - 16 CONTINUE - WRITE (0, '(A)') ' Default values for PRINT, SCFTOL ? (Y/N/H)' - READ (5, '(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (5) - GO TO 16 - ENDIF - IF (ANS/='Y' .AND. ANS/='y') THEN + ' MAXIMUM is ', NOD + GO TO 50 + ENDIF + ND = NO - 2 + OMIT = .NOT.STRONG + ENDIF + 16 CONTINUE + WRITE (0, '(A)') ' Default values for PRINT, SCFTOL ? (Y/N/H)' + READ (5, '(A)') ANS + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (5) + GO TO 16 + ENDIF + IF (ANS/='Y' .AND. ANS/='y') THEN !CFF W>= D+7 (was E6.1) - WRITE (0, '(A)') ' Input FORMAT(L1, 1X, E8.1) ' - READ (5, '(L1,1X,E8.1)') PRINT, SCFTOL - ENDIF - 17 CONTINUE - WRITE (0, '(A)') ' Default values for NSCF, IC ? (Y/N/H) ' - READ (5, '(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (6) - GO TO 17 - ENDIF - IF (ANS/='Y' .AND. ANS/='y') THEN - WRITE (0, '(A)') ' Input FORMAT(I2, 1X, I1) ' - READ (5, '(I2,1X,I1)') NSCF, IC - ENDIF - 18 CONTINUE - WRITE (0, '(A)') ' Default values for TRACE ? (Y/N/H) ' - READ (5, '(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (7) - GO TO 18 - ENDIF - IF (ANS=='N' .OR. ANS=='n') TRACE = .TRUE. - ENDIF - ENDIF + WRITE (0, '(A)') ' Input FORMAT(L1, 1X, E8.1) ' + READ (5, '(L1,1X,E8.1)') PRINT, SCFTOL + ENDIF + 17 CONTINUE + WRITE (0, '(A)') ' Default values for NSCF, IC ? (Y/N/H) ' + READ (5, '(A)') ANS + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (6) + GO TO 17 + ENDIF + IF (ANS/='Y' .AND. ANS/='y') THEN + WRITE (0, '(A)') ' Input FORMAT(I2, 1X, I1) ' + READ (5, '(I2,1X,I1)') NSCF, IC + ENDIF + 18 CONTINUE + WRITE (0, '(A)') ' Default values for TRACE ? (Y/N/H) ' + READ (5, '(A)') ANS + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (7) + GO TO 18 + ENDIF + IF (ANS=='N' .OR. ANS=='n') TRACE = .TRUE. + ENDIF + ENDIF ! ! ! ***** PERFORM THE MCHF ITERATION ! - CALL SCF (ETOTAL, SCFTOL, EREL) + CALL SCF (ETOTAL, SCFTOL, EREL) ! ! ***** OUTPUT RESULTS IF PRINT = .TRUE. ! - CALL OUTPUT (PRINT) - IF (.NOT.FAIL) THEN - CALL SUMMRY (ETOTAL, EREL) - 19 CONTINUE - WRITE (0, '(/A)') ' Additional parameters ? (Y/N/H) ' + CALL OUTPUT (PRINT) + IF (.NOT.FAIL) THEN + CALL SUMMRY (ETOTAL, EREL) + 19 CONTINUE + WRITE (0, '(/A)') ' Additional parameters ? (Y/N/H) ' READ(5,'(A1)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (8) - GO TO 19 - ENDIF - IF (ANS=='Y' .OR. ANS=='y') CALL MENU + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (8) + GO TO 19 + ENDIF + IF (ANS=='Y' .OR. ANS=='y') CALL MENU ! ! ***** CHECK FOR ISOELECTRONIC SEQUENCE OR END OF CASE. ! - 20 CONTINUE - WRITE (0, '(/A)') ' Do you wish to continue along the sequence ? ' + 20 CONTINUE + WRITE (0, '(/A)') ' Do you wish to continue along the sequence ? ' READ(5,'(A1)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (9) - GO TO 20 - ENDIF - IF (ANS=='Y' .OR. ANS=='y') THEN + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (9) + GO TO 20 + ENDIF + IF (ANS=='Y' .OR. ANS=='y') THEN WRITE (0, *) ' Enter: ATOM, ZZ, (ACC(I),I=1,NWF) in ', & - ' format(A6,F6.0,(20F3.1))' - READ (5, '(A6,F6.0,(20F3.1))') ATOM, ZZ, (ACC(I),I=1,NWF) + ' format(A6,F6.0,(20F3.1))' + READ (5, '(A6,F6.0,(20F3.1))') ATOM, ZZ, (ACC(I),I=1,NWF) ! ! ***** SCALE RESULTS FOR ANOTHER MEMBER OF THE ISOELECTRONIC SEQUENCE ! - CALL SCALE (ZZ) - WRITE (3, 14) ATOM, TERM - 14 FORMAT('1',9X,2A6) - CALL ORTHOG - GO TO 13 - ENDIF - ENDIF + CALL SCALE (ZZ) + WRITE (3, 14) ATOM, TERM + 14 FORMAT('1',9X,2A6) + CALL ORTHOG + GO TO 13 + ENDIF + ENDIF ! ! ***** DETERMINE END OF CASE ! - WRITE (6, '(2/A/A,2/)') ' END OF CASE', ' ===========' - STOP - END PROGRAM MAIN + WRITE (6, '(2/A/A,2/)') ' END OF CASE', ' ===========' + STOP + END PROGRAM MAIN ! @@ -881,51 +881,51 @@ END PROGRAM MAIN ! ! Determine the coefficient in the potential for electron i of ! Y^k(j,j) - - REAL(KIND(0.0D0)) FUNCTION A (I, J, K) + + REAL(KIND(0.0D0)) FUNCTION A (I, J, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE COEFF_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: SUM + USE vast_kind_param, ONLY: DOUBLE + USE COEFF_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: SUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ca_I + USE ca_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I - INTEGER , INTENT(IN) :: J - INTEGER :: K + INTEGER , INTENT(IN) :: I + INTEGER , INTENT(IN) :: J + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISTART - REAL(DOUBLE) :: C -!----------------------------------------------- -! - IF (I>NCLOSD .AND. J>NCLOSD) THEN - ISTART = IJPTR(I-NCLOSD,J-NCLOSD) + 1 - A = COEF(ISTART+K/2) - ELSE IF (I == J) THEN - C = SUM(I) - D1 - IF (K == 0) THEN - A = C - ELSE - A = -C*CA(L(I),K) - ENDIF - ELSE IF (K == 0) THEN - A = SUM(J) - ELSE - A = D0 - ENDIF - RETURN - END FUNCTION A + INTEGER :: ISTART + REAL(DOUBLE) :: C +!----------------------------------------------- +! + IF (I>NCLOSD .AND. J>NCLOSD) THEN + ISTART = IJPTR(I-NCLOSD,J-NCLOSD) + 1 + A = COEF(ISTART+K/2) + ELSE IF (I == J) THEN + C = SUM(I) - D1 + IF (K == 0) THEN + A = C + ELSE + A = -C*CA(L(I),K) + ENDIF + ELSE IF (K == 0) THEN + A = SUM(J) + ELSE + A = D0 + ENDIF + RETURN + END FUNCTION A ! ! ---------------------------------------------------------------- ! A D D @@ -934,40 +934,40 @@ END FUNCTION A ! Add a Slater integral to the data structure associated with the ! energy expression ! - SUBROUTINE ADD(C, K, I, J, FIRST) + SUBROUTINE ADD(C, K, I, J, FIRST) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE COEFF_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: SUM + USE vast_kind_param, ONLY: DOUBLE + USE COEFF_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: SUM IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: K - INTEGER , INTENT(IN) :: I - INTEGER , INTENT(IN) :: J - REAL(DOUBLE) , INTENT(IN) :: C - LOGICAL , INTENT(IN) :: FIRST + INTEGER , INTENT(IN) :: K + INTEGER , INTENT(IN) :: I + INTEGER , INTENT(IN) :: J + REAL(DOUBLE) , INTENT(IN) :: C + LOGICAL , INTENT(IN) :: FIRST !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IP + INTEGER :: IP !----------------------------------------------- ! - IP = IJPTR(I-NCLOSD,J-NCLOSD) - - IF (FIRST) THEN - COEF(IP+K/2+1) = C/SUM(I) + COEF(IP+K/2+1) - ELSE - IP = IP + MIN(L(I),L(J)) + 1 + (K - ABS(L(I)-L(J)))/2 + 1 - COEF(IP) = COEF(IP) + C/SUM(I) - ENDIF - RETURN - END SUBROUTINE ADD + IP = IJPTR(I-NCLOSD,J-NCLOSD) + + IF (FIRST) THEN + COEF(IP+K/2+1) = C/SUM(I) + COEF(IP+K/2+1) + ELSE + IP = IP + MIN(L(I),L(J)) + 1 + (K - ABS(L(I)-L(J)))/2 + 1 + COEF(IP) = COEF(IP) + C/SUM(I) + ENDIF + RETURN + END SUBROUTINE ADD ! ! ---------------------------------------------------------------- ! A R R A Y @@ -975,71 +975,71 @@ END SUBROUTINE ADD ! ! Set up the data structure associated with the average energy ! - SUBROUTINE ARRAY + SUBROUTINE ARRAY !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE COEFF_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: SUM + USE vast_kind_param, ONLY: DOUBLE + USE COEFF_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: SUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ca_I - USE cb_I + USE ca_I + USE cb_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IP, I, ISUMI, J, ISUMJ, K - REAL(DOUBLE) :: DSUMI, DSUMJ, C + INTEGER :: IP, I, ISUMI, J, ISUMJ, K + REAL(DOUBLE) :: DSUMI, DSUMJ, C !----------------------------------------------- ! - IP = 0 - DO I = NCLOSD + 1, NWF - ISUMI = SUM(I) - DSUMI = SUM(I) - ISUMI - DO J = NCLOSD + 1, NWF - ISUMJ = SUM(J) - DSUMJ = SUM(J) - ISUMJ - IF (I /= J) THEN - C = SUM(J) + IP = 0 + DO I = NCLOSD + 1, NWF + ISUMI = SUM(I) + DSUMI = SUM(I) - ISUMI + DO J = NCLOSD + 1, NWF + ISUMJ = SUM(J) + DSUMJ = SUM(J) - ISUMJ + IF (I /= J) THEN + C = SUM(J) IF (DSUMI/=D0 .AND. DSUMJ/=D0) C = (DSUMI*(ISUMI + 1)*ISUMJ + & - DSUMJ*(ISUMJ + 1)*ISUMI)/SUM(I) - ELSE - C = SUM(I) - D1 - IF (DSUMI /= D0) C = (ISUMI*(SUM(I)+DSUMI-1))/SUM(I) - ENDIF + DSUMJ*(ISUMJ + 1)*ISUMI)/SUM(I) + ELSE + C = SUM(I) - D1 + IF (DSUMI /= D0) C = (ISUMI*(SUM(I)+DSUMI-1))/SUM(I) + ENDIF ! - IJPTR(I-NCLOSD,J-NCLOSD) = IP + IJPTR(I-NCLOSD,J-NCLOSD) = IP ! ! ***** Direct contribution ! - DO K = 0, 2*MIN0(L(I),L(J)), 2 - IP = IP + 1 - IF (IP > 200) STOP ' COEF array too small: MAX = (200)' - COEF(IP) = D0 - IF (K == 0) THEN - COEF(IP) = C - ELSE IF (I == J) THEN - COEF(IP) = -C*CA(L(I),K) - ENDIF - END DO + DO K = 0, 2*MIN0(L(I),L(J)), 2 + IP = IP + 1 + IF (IP > 200) STOP ' COEF array too small: MAX = (200)' + COEF(IP) = D0 + IF (K == 0) THEN + COEF(IP) = C + ELSE IF (I == J) THEN + COEF(IP) = -C*CA(L(I),K) + ENDIF + END DO ! ! ***** Exchange contribution ! - IF (I == J) CYCLE - DO K = ABS(L(I)-L(J)), L(I) + L(J), 2 - IP = IP + 1 - IF (IP > 200) STOP ' COEF array too small: MAX = (200)' - COEF(IP) = -C*CB(L(I),L(J),K) - END DO - END DO - END DO - RETURN - END SUBROUTINE ARRAY + IF (I == J) CYCLE + DO K = ABS(L(I)-L(J)), L(I) + L(J), 2 + IP = IP + 1 + IF (IP > 200) STOP ' COEF array too small: MAX = (200)' + COEF(IP) = -C*CB(L(I),L(J),K) + END DO + END DO + END DO + RETURN + END SUBROUTINE ARRAY ! ! ---------------------------------------------------------------- ! B @@ -1048,269 +1048,269 @@ END SUBROUTINE ARRAY ! Determine the coefficient of the Y^k(i,j)P(j) term in the exchange ! expression of electron i ! - REAL(KIND(0.0D0)) FUNCTION B (I, J, K) + REAL(KIND(0.0D0)) FUNCTION B (I, J, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE COEFF_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: SUM + USE vast_kind_param, ONLY: DOUBLE + USE COEFF_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: SUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cb_I + USE cb_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I - INTEGER , INTENT(IN) :: J - INTEGER :: K + INTEGER , INTENT(IN) :: I + INTEGER , INTENT(IN) :: J + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LL, ISTART, KK + INTEGER :: LL, ISTART, KK !----------------------------------------------- ! - IF (I == J) THEN - B = D0 - ELSE IF (I>NCLOSD .AND. J>NCLOSD) THEN + IF (I == J) THEN + B = D0 + ELSE IF (I>NCLOSD .AND. J>NCLOSD) THEN ! ! ..... LL is the number of direct terms ! ISTART the beginning of the exchange terms ! - LL = MIN(L(I),L(J)) + 1 - ISTART = IJPTR(I-NCLOSD,J-NCLOSD) + 1 + LL - KK = (K - ABS(L(I)-L(J)))/2 - B = COEF(ISTART+KK) - ELSE - B = -SUM(J)*CB(L(I),L(J),K) - ENDIF - RETURN - END FUNCTION B + LL = MIN(L(I),L(J)) + 1 + ISTART = IJPTR(I-NCLOSD,J-NCLOSD) + 1 + LL + KK = (K - ABS(L(I)-L(J)))/2 + B = COEF(ISTART+KK) + ELSE + B = -SUM(J)*CB(L(I),L(J),K) + ENDIF + RETURN + END FUNCTION B ! ! ------------------------------------------------------------------ ! B W I N T ! ------------------------------------------------------------------ ! - SUBROUTINE BWINT(LC, LO) + SUBROUTINE BWINT(LC, LO) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE BLUME_C + USE vast_kind_param, ONLY: DOUBLE + USE BLUME_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: LC, LO + INTEGER , INTENT(IN) :: LC, LO !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LC1 + INTEGER :: LC1 !----------------------------------------------- ! ! ... LC IS THE L-VALUE OF THE FILLED SUBSHELL, LO IS THE L-VALUE ! OF THE PARTIALLY-FILLED SUBSHELL. ! - IF (LC>3 .OR. LO>4) THEN - WRITE (0, 100) LC, LO - 100 FORMAT(' INCORRECT CALLING OF BWINT WITH LC =',I2,', LO =',I2) - ENDIF + IF (LC>3 .OR. LO>4) THEN + WRITE (0, 100) LC, LO + 100 FORMAT(' INCORRECT CALLING OF BWINT WITH LC =',I2,', LO =',I2) + ENDIF IF (LC == 0) then ! ! ... S-P ! IF (LO == 1) THEN - COEFNK(1) = 1.D0 - COEFN2(1) = -2.D0 - COEFVK(1) = 1.D0 - RETURN + COEFNK(1) = 1.D0 + COEFN2(1) = -2.D0 + COEFVK(1) = 1.D0 + RETURN ! ! ... S-D ! ELSE IF (LO == 2) THEN - COEFNK(1) = 6.D0/5.D0 - COEFN2(1) = -9.D0/5.D0 - COEFVK(1) = 3.D0/5.D0 - RETURN + COEFNK(1) = 6.D0/5.D0 + COEFN2(1) = -9.D0/5.D0 + COEFVK(1) = 3.D0/5.D0 + RETURN ! ! ... S-F ! ELSE IF (LO == 3) THEN - COEFNK(1) = 9.D0/7.D0 - COEFN2(1) = -12.D0/7.D0 - COEFVK(1) = 3.D0/7.D0 - RETURN + COEFNK(1) = 9.D0/7.D0 + COEFN2(1) = -12.D0/7.D0 + COEFVK(1) = 3.D0/7.D0 + RETURN ! ! ... S-G ! ELSE IF (LO == 4) THEN - COEFNK(1) = 4.D0/3.D0 - COEFN2(1) = -5.D0/3.D0 - COEFVK(1) = 1.D0/3.D0 - RETURN + COEFNK(1) = 4.D0/3.D0 + COEFN2(1) = -5.D0/3.D0 + COEFVK(1) = 1.D0/3.D0 + RETURN END IF ELSE IF (LC == 1) then ! ! ... P-P ! IF (LO ==1 ) THEN - COEFNK(1) = 0.D0 - COEFN2(1) = 3.D0 - COEFVK(1) = 9.D0/5.D0 - RETURN + COEFNK(1) = 0.D0 + COEFN2(1) = 3.D0 + COEFVK(1) = 9.D0/5.D0 + RETURN ! ! ... P-D -! +! ELSE IF (LO == 2) THEN - COEFNK(1) = 3.D0/7.D0 - COEFNK(2) = 36.D0/35.D0 - COEFN2(1) = -12.D0/5.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = 3.D0/5.D0 - COEFVK(2) = 36.D0/35.D0 - RETURN + COEFNK(1) = 3.D0/7.D0 + COEFNK(2) = 36.D0/35.D0 + COEFN2(1) = -12.D0/5.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = 3.D0/5.D0 + COEFVK(2) = 36.D0/35.D0 + RETURN ! ! ... P-F ! ELSE IF (LO == 3) THEN - COEFNK(1) = 1.D0/7.D0 - COEFNK(2) = 10.D0/7.D0 - COEFN2(1) = -18.D0/7.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = 18.D0/35.D0 - COEFVK(2) = 5.D0/7.D0 - RETURN + COEFNK(1) = 1.D0/7.D0 + COEFNK(2) = 10.D0/7.D0 + COEFN2(1) = -18.D0/7.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = 18.D0/35.D0 + COEFVK(2) = 5.D0/7.D0 + RETURN ! ! ... P-G ! -! +! ELSE IF (LO == 4) THEN - COEFNK(1) = 5.D0/77.D0 - COEFNK(2) = 18.D0/11.D0 - COEFN2(1) = -18.D0/7.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = 3.D0/7.D0 - COEFVK(2) = 6.D0/11.D0 - RETURN + COEFNK(1) = 5.D0/77.D0 + COEFNK(2) = 18.D0/11.D0 + COEFN2(1) = -18.D0/7.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = 3.D0/7.D0 + COEFVK(2) = 6.D0/11.D0 + RETURN END IF ELSE IF (LC == 2) then ! ! ... D-P ! IF (LO == 1) then - COEFNK(1) = 59.D0/7.D0 - COEFNK(2) = -18.D0/7.D0 - COEFN2(1) = -4.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = -1.D0 - COEFVK(2) = 18.D0/7.D0 - RETURN + COEFNK(1) = 59.D0/7.D0 + COEFNK(2) = -18.D0/7.D0 + COEFN2(1) = -4.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = -1.D0 + COEFVK(2) = 18.D0/7.D0 + RETURN ! ! ... D-D ! ELSE IF (LO == 2) THEN - COEFNK(1) = 6.D0/7.D0 - COEFNK(2) = 0.D0 - COEFN2(1) = 3.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = 3.D0/7.D0 - COEFVK(2) = 10.D0/7.D0 - RETURN + COEFNK(1) = 6.D0/7.D0 + COEFNK(2) = 0.D0 + COEFN2(1) = 3.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = 3.D0/7.D0 + COEFVK(2) = 10.D0/7.D0 + RETURN ! ! ... D-F ! ELSE IF (LO == 3) THEN - COEFNK(1) = 9.D0/7.D0 - COEFNK(2) = -13.D0/77.D0 - COEFNK(3) = 75.D0/77.D0 - COEFN2(1) = -18.D0/7.D0 - COEFN2(2) = 0.D0 - COEFN2(3) = 0.D0 - COEFVK(1) = 3.D0/7.D0 - COEFVK(2) = 3.D0/7.D0 - COEFVK(3) = 75.D0/77.D0 - RETURN + COEFNK(1) = 9.D0/7.D0 + COEFNK(2) = -13.D0/77.D0 + COEFNK(3) = 75.D0/77.D0 + COEFN2(1) = -18.D0/7.D0 + COEFN2(2) = 0.D0 + COEFN2(3) = 0.D0 + COEFVK(1) = 3.D0/7.D0 + COEFVK(2) = 3.D0/7.D0 + COEFVK(3) = 75.D0/77.D0 + RETURN ! ! ... D-G ! ELSE IF (LO == 4) THEN - COEFNK(1) = 741.D0/693.D0 - COEFNK(2) = -215.D0/429.D0 - COEFNK(3) = 210.D0/143.D0 - COEFN2(1) = -3.D0 - COEFN2(2) = 0.D0 - COEFN2(3) = 0.D0 - COEFVK(1) = 3.D0/7.D0 - COEFVK(2) = 255.D0/693.D0 - COEFVK(3) = 105.D0/143.D0 - RETURN + COEFNK(1) = 741.D0/693.D0 + COEFNK(2) = -215.D0/429.D0 + COEFNK(3) = 210.D0/143.D0 + COEFN2(1) = -3.D0 + COEFN2(2) = 0.D0 + COEFN2(3) = 0.D0 + COEFVK(1) = 3.D0/7.D0 + COEFVK(2) = 255.D0/693.D0 + COEFVK(3) = 105.D0/143.D0 + RETURN END IF ELSE IF (LC == 3) THEN ! ! ... F-P IF (LO == 1) THEN - COEFNK(1) = 52.D0/3.D0 - COEFNK(2) = -20.D0/3.D0 - COEFN2(1) = -9.D0 - COEFN2(2) = 0.D0 - COEFVK(1) = -9.D0/5.D0 - COEFVK(2) = 10.D0/3.D0 - RETURN + COEFNK(1) = 52.D0/3.D0 + COEFNK(2) = -20.D0/3.D0 + COEFN2(1) = -9.D0 + COEFN2(2) = 0.D0 + COEFVK(1) = -9.D0/5.D0 + COEFVK(2) = 10.D0/3.D0 + RETURN ! ! ... F-D ! ELSE IF (LO == 2) THEN - COEFNK(1) = 5.D0 - COEFNK(2) = 142.D0/55.D0 - COEFNK(3) = -20.D0/11.D0 - COEFN2(1) = -18.D0/5.D0 - COEFN2(2) = 0.D0 - COEFN2(3) = 0.D0 - COEFVK(1) = -3.D0/5.D0 - COEFVK(2) = 2.D0/5.D0 - COEFVK(3) = 20.D0/11.D0 - RETURN + COEFNK(1) = 5.D0 + COEFNK(2) = 142.D0/55.D0 + COEFNK(3) = -20.D0/11.D0 + COEFN2(1) = -18.D0/5.D0 + COEFN2(2) = 0.D0 + COEFN2(3) = 0.D0 + COEFVK(1) = -3.D0/5.D0 + COEFVK(2) = 2.D0/5.D0 + COEFVK(3) = 20.D0/11.D0 + RETURN ! ! ... F-F ! ELSE IF (LO == 3) THEN - COEFNK(1) = 1.D0 - COEFNK(2) = 5.D0/11.D0 - COEFNK(3) = 0.D0 - COEFN2(1) = 3.D0 - COEFN2(2) = 0.D0 - COEFN2(3) = 0.D0 - COEFVK(1) = 1.D0/5.D0 - COEFVK(2) = 5.D0/11.D0 - COEFVK(3) = 175.D0/143.D0 - RETURN + COEFNK(1) = 1.D0 + COEFNK(2) = 5.D0/11.D0 + COEFNK(3) = 0.D0 + COEFN2(1) = 3.D0 + COEFN2(2) = 0.D0 + COEFN2(3) = 0.D0 + COEFVK(1) = 1.D0/5.D0 + COEFVK(2) = 5.D0/11.D0 + COEFVK(3) = 175.D0/143.D0 + RETURN ! ! ... F-G ! ELSE IF (LO == 4) THEN - COEFNK(1) = 53.D0/33.D0 - COEFNK(2) = 57.D0/143.D0 - COEFNK(3) = -115.D0/429.D0 - COEFNK(4) = 392.D0/429.D0 - COEFN2(1) = -8.D0/3.D0 - COEFN2(2) = 0.D0 - COEFN2(3) = 0.D0 - COEFN2(4) = 0.D0 - COEFVK(1) = 1.D0/3.D0 - COEFVK(2) = 3.D0/11.D0 - COEFVK(3) = 57.D0/143.D0 - COEFVK(4) = 392.D0/429.D0 - RETURN + COEFNK(1) = 53.D0/33.D0 + COEFNK(2) = 57.D0/143.D0 + COEFNK(3) = -115.D0/429.D0 + COEFNK(4) = 392.D0/429.D0 + COEFN2(1) = -8.D0/3.D0 + COEFN2(2) = 0.D0 + COEFN2(3) = 0.D0 + COEFN2(4) = 0.D0 + COEFVK(1) = 1.D0/3.D0 + COEFVK(2) = 3.D0/11.D0 + COEFVK(3) = 57.D0/143.D0 + COEFVK(4) = 392.D0/429.D0 + RETURN END IF ELSE - WRITE (0, 100) LC, LO + WRITE (0, 100) LC, LO END IF - END SUBROUTINE BWINT + END SUBROUTINE BWINT ! ! ---------------------------------------------------------------- ! B W Z E T A @@ -1319,148 +1319,148 @@ END SUBROUTINE BWINT ! CORRECTIONS FOR THE OTHER ELECTRONS ! USING THE FORMULA DERIVED BY Blume and Watson. ! - REAL(KIND(0.0D0)) FUNCTION BWZETA (I1) + REAL(KIND(0.0D0)) FUNCTION BWZETA (I1) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE BLUME_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: SUM + USE vast_kind_param, ONLY: DOUBLE + USE BLUME_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: SUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quadr_I - USE sn_I - USE bwint_I - USE vk_I + USE quadr_I + USE sn_I + USE bwint_I + USE vk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I1 + INTEGER :: I1 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LB, I, LA, KE1, IP, K - REAL(DOUBLE), DIMENSION(3) :: SS - REAL(DOUBLE) :: ZETA, C -!----------------------------------------------- -! - ZETA = FINE*Z*QUADR(I1,I1,-3) - - LB = L(I1) - DO I = 1, NWF - IF (I == I1) CYCLE - LA = L(I) - ZETA = ZETA - SUM(I)*SN(I1,I,I1,I,0) - IF (SUM(I) /= 4*L(I) + 2) CYCLE - CALL BWINT (LA, LB) - KE1 = 2 - IF (LA /= LB) KE1 = IABS(LA - LB) - IP = 0 - DO K = KE1, LA + LB, 2 - IP = IP + 1 + INTEGER :: LB, I, LA, KE1, IP, K + REAL(DOUBLE), DIMENSION(3) :: SS + REAL(DOUBLE) :: ZETA, C +!----------------------------------------------- +! + ZETA = FINE*Z*QUADR(I1,I1,-3) + + LB = L(I1) + DO I = 1, NWF + IF (I == I1) CYCLE + LA = L(I) + ZETA = ZETA - SUM(I)*SN(I1,I,I1,I,0) + IF (SUM(I) /= 4*L(I) + 2) CYCLE + CALL BWINT (LA, LB) + KE1 = 2 + IF (LA /= LB) KE1 = IABS(LA - LB) + IP = 0 + DO K = KE1, LA + LB, 2 + IP = IP + 1 ZETA = ZETA + COEFN2(IP)*SN(I1,I,I,I1,K - 2) + COEFNK(IP)*SN(I,I1,& - I1,I,K) + COEFVK(IP)*(VK(I1,I,I,I1,K - 1) - VK(I,I1,I1,I,K - 1)) - END DO - WRITE (*, *) 'zeta,i', ZETA, I - - END DO - ZETA = D2*ZETA - WRITE (*, *) 'zeta', ZETA - C = SUM(I1) - IF (C /= D1) THEN - SS(1) = SN(I1,I1,I1,I1,0) - C = C + C - D3 - ZETA = ZETA - C*SS(1) - IF (LB == 2) THEN - SS(2) = SN(I1,I1,I1,I1,2) - ZETA = ZETA + SS(2)*6.D0/7.D0 - ELSE IF (LB == 3) THEN - SS(2) = SN(I1,I1,I1,I1,2) - SS(3) = SN(I1,I1,I1,I1,4) - ZETA = ZETA + SS(2) + SS(3)/2.2D0 - ENDIF - ENDIF - WRITE (*, *) 'zeta', ZETA - - BWZETA = ZETA - RETURN - END FUNCTION BWZETA + I1,I,K) + COEFVK(IP)*(VK(I1,I,I,I1,K - 1) - VK(I,I1,I1,I,K - 1)) + END DO + WRITE (*, *) 'zeta,i', ZETA, I + + END DO + ZETA = D2*ZETA + WRITE (*, *) 'zeta', ZETA + C = SUM(I1) + IF (C /= D1) THEN + SS(1) = SN(I1,I1,I1,I1,0) + C = C + C - D3 + ZETA = ZETA - C*SS(1) + IF (LB == 2) THEN + SS(2) = SN(I1,I1,I1,I1,2) + ZETA = ZETA + SS(2)*6.D0/7.D0 + ELSE IF (LB == 3) THEN + SS(2) = SN(I1,I1,I1,I1,2) + SS(3) = SN(I1,I1,I1,I1,4) + ZETA = ZETA + SS(2) + SS(3)/2.2D0 + ENDIF + ENDIF + WRITE (*, *) 'zeta', ZETA + + BWZETA = ZETA + RETURN + END FUNCTION BWZETA ! ! ------------------------------------------------------------------ ! C A ! ------------------------------------------------------------------ ! - REAL(KIND(0.0D0)) FUNCTION CA (L, K) + REAL(KIND(0.0D0)) FUNCTION CA (L, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE EAV_C + USE vast_kind_param, ONLY: DOUBLE + USE EAV_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rme_I + USE rme_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: L - INTEGER :: K + INTEGER :: L + INTEGER :: K !----------------------------------------------- ! - IF (L <= 4) THEN - CA = CCA((L*(L-1)+K)/2) - ELSE + IF (L <= 4) THEN + CA = CCA((L*(L-1)+K)/2) + ELSE ! Corrected according to Prof. P. Bogdanovich 1996.03.18. ! CA = RME(L,L,K)**2 - CA = RME(L,L,K)**2/((2*L + 1)*(4*L + 1)) - ENDIF - RETURN - END FUNCTION CA + CA = RME(L,L,K)**2/((2*L + 1)*(4*L + 1)) + ENDIF + RETURN + END FUNCTION CA ! ! ----------------------------------------------------------------- ! C B ! ----------------------------------------------------------------- - REAL(KIND(0.0D0)) FUNCTION CB (L, LP, K) + REAL(KIND(0.0D0)) FUNCTION CB (L, LP, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE EAV_C + USE vast_kind_param, ONLY: DOUBLE + USE EAV_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rme_I + USE rme_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: L, LP, K + INTEGER :: L, LP, K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER , DIMENSION(0:4) :: ICBPTR = (/1, 6, 14, 23, 31/) - INTEGER :: L1, L2 -!----------------------------------------------- -! - IF (L <= LP) THEN - L1 = L - L2 = LP - ELSE - L1 = LP - L2 = L - ENDIF - IF (L2 <= 4) THEN - CB = CCB(ICBPTR(L1)+(K+L1-L2)/2+(L1+1)*(L2-L1)) - ELSE - CB = RME(L,LP,K)**2/(2*(2*L + 1)*(2*LP + 1)) - ENDIF - RETURN - END FUNCTION CB + INTEGER :: L1, L2 +!----------------------------------------------- +! + IF (L <= LP) THEN + L1 = L + L2 = LP + ELSE + L1 = LP + L2 = L + ENDIF + IF (L2 <= 4) THEN + CB = CCB(ICBPTR(L1)+(K+L1-L2)/2+(L1+1)*(L2-L1)) + ELSE + CB = RME(L,LP,K)**2/(2*(2*L + 1)*(2*LP + 1)) + ENDIF + RETURN + END FUNCTION CB ! ! ------------------------------------------------------------------ ! D A T A @@ -1469,330 +1469,330 @@ END FUNCTION CB ! and type of electrons in each configuration, as well as data ! associated with the energy expression are read and stored. ! - SUBROUTINE DATA + SUBROUTINE DATA !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE LABEL_C - USE PARAM_C - USE WAVE_C, ONLY: EK, E, SUM, S, ACC, METH, IORD, NOD - USE RADIAL_C, ONLY: AZ, L, N - USE ESTP_C, ONLY: IND - USE INOUT_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE LABEL_C + USE PARAM_C + USE WAVE_C, ONLY: EK, E, SUM, S, ACC, METH, IORD, NOD + USE RADIAL_C, ONLY: AZ, L, N + USE ESTP_C, ONLY: IND + USE INOUT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE reform_I - USE lval_I - USE help_I - USE reord_I - USE array_I - USE enexpr_I - USE eptr_I - USE add_I - USE wavefn_I + USE reform_I + USE lval_I + USE help_I + USE reord_I + USE array_I + USE enexpr_I + USE eptr_I + USE add_I + USE wavefn_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J1, J2, I, J, IFULL, MAXORB, K, NIT, JJ, NEXT, IERR, KKK, & - ISELEC, KFG, IFG, JFG, JP, N1, L1, N2, L2, ITEMP - REAL(DOUBLE) :: SS, CFG - LOGICAL :: FIRST, STRONG, DONE, ORDERD - CHARACTER :: ANS, STRING*50, EL1*3, EL2*3 - CHARACTER , DIMENSION(18) :: ELCSD*3 - CHARACTER(LEN=1) :: ASTER = '*', W + ISELEC, KFG, IFG, JFG, JP, N1, L1, N2, L2, ITEMP + REAL(DOUBLE) :: SS, CFG + LOGICAL :: FIRST, STRONG, DONE, ORDERD + CHARACTER :: ANS, STRING*50, EL1*3, EL2*3 + CHARACTER , DIMENSION(18) :: ELCSD*3 + CHARACTER(LEN=1) :: ASTER = '*', W !----------------------------------------------- ! - 1 FORMAT(18(1X,A3)) - 7 FORMAT(A3,F6.0,I3,I3,F3.1) - 5 CONTINUE + 1 FORMAT(18(1X,A3)) + 7 FORMAT(A3,F6.0,I3,I3,F3.1) + 5 CONTINUE WRITE (0, '(A/A)') ' Enter ATOM,TERM,Z', & - ' Examples: O,3P,8. or Oxygen,AV,8.' - READ (5, '(A50)') STRING - I = INDEX(STRING,',') - IF (I == 0) THEN - WRITE (0, *) ' ATOM, TERM, and Z must be separated by commas ' - GO TO 5 - ENDIF - ATOM = STRING(1:I-1) - J = INDEX(STRING(I+1:),',') - IF (J == 0) THEN - WRITE (0, *) ' ATOM, TERM, and Z must be separated by commas ' - GO TO 5 - ENDIF - TERM = STRING(I+1:I+J-1) - READ (STRING(I+J+1:), '(F3.0)') Z + ' Examples: O,3P,8. or Oxygen,AV,8.' + READ (5, '(A50)') STRING + I = INDEX(STRING,',') + IF (I == 0) THEN + WRITE (0, *) ' ATOM, TERM, and Z must be separated by commas ' + GO TO 5 + ENDIF + ATOM = STRING(1:I-1) + J = INDEX(STRING(I+1:),',') + IF (J == 0) THEN + WRITE (0, *) ' ATOM, TERM, and Z must be separated by commas ' + GO TO 5 + ENDIF + TERM = STRING(I+1:I+J-1) + READ (STRING(I+J+1:), '(F3.0)') Z ! ! ***** INPUT COMMON CLOSED SHELLS ! - 2 CONTINUE - WRITE (0, *) + 2 CONTINUE + WRITE (0, *) WRITE (0, '(A,A)') ' List the CLOSED shells in the fields indicated', & - ' (blank line if none)' - WRITE (0, '(A)') ' ... ... ... ... ... ... ... ... etc.' - READ (5, 1) (ELCSD(I),I=1,18) + ' (blank line if none)' + WRITE (0, '(A)') ' ... ... ... ... ... ... ... ... etc.' + READ (5, 1) (ELCSD(I),I=1,18) ! ! ***** INPUT THE CONFIGURATION ! WRITE (0, '(/A,A/A)') ' Enter electrons outside CLOSED shells ', & - '(blank line if none)', ' Example: 2s(1)2p(3)' - READ (5, '(A)') STRING - CALL REFORM (STRING, CONFIG) + '(blank line if none)', ' Example: 2s(1)2p(3)' + READ (5, '(A)') STRING + CALL REFORM (STRING, CONFIG) ! ! Determine the number of closed shells ! - I = 0 - SS = D0 - 12 CONTINUE - IF (ELCSD(I+1) /= ' ') THEN - I = I + 1 - EL(I) = ADJUSTR(ELCSD(I)) - J = 3 - IF (EL(I)(1:1) /= ' ') J = 2 - L(I) = LVAL(EL(I)(J:J)) - N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 - IFULL = 2*(2*L(I)+1) - SUM(I) = IFULL - S(I) = SS + IFULL/2 - SS = SS + IFULL - METH(I) = 1 - ACC(I) = D0 - IND(I) = 0 - IF (IUF /= 0) IND(I) = -1 - IF (I < 18) GO TO 12 - STOP ' TOO MANY CLOSED SHELLS: MAX = 18' - ENDIF - NCLOSD = I + I = 0 + SS = D0 + 12 CONTINUE + IF (ELCSD(I+1) /= ' ') THEN + I = I + 1 + EL(I) = ADJUSTR(ELCSD(I)) + J = 3 + IF (EL(I)(1:1) /= ' ') J = 2 + L(I) = LVAL(EL(I)(J:J)) + N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 + IFULL = 2*(2*L(I)+1) + SUM(I) = IFULL + S(I) = SS + IFULL/2 + SS = SS + IFULL + METH(I) = 1 + ACC(I) = D0 + IND(I) = 0 + IF (IUF /= 0) IND(I) = -1 + IF (I < 18) GO TO 12 + STOP ' TOO MANY CLOSED SHELLS: MAX = 18' + ENDIF + NCLOSD = I ! ! ***** DETERMINE THE OTHER ELECTRONS ! - MAXORB = NCLOSD - STRING = CONFIG - J = 2 - I = 0 - 16 CONTINUE - IF (STRING(J:J+2) /= ' ') THEN + MAXORB = NCLOSD + STRING = CONFIG + J = 2 + I = 0 + 16 CONTINUE + IF (STRING(J:J+2) /= ' ') THEN ! ! --------- An electron has been found; is it a new one? ! - I = I + 1 - IF (I > 5) STOP ' TOO MANY SHELLS: MAX= (5)' - EL1 = STRING(J:J+2) - K = NCLOSD + 1 - 17 CONTINUE - IF (K <= MAXORB) THEN - IF (EL(K) /= EL1) THEN - K = K + 1 - IF (K > NWFD) THEN - WRITE (0, '(A,I4)') ' TOO MANY ELECTRONS: MAX =', NWFD - GO TO 2 - ELSE - GO TO 17 - ENDIF - ENDIF - ELSE + I = I + 1 + IF (I > 5) STOP ' TOO MANY SHELLS: MAX= (5)' + EL1 = STRING(J:J+2) + K = NCLOSD + 1 + 17 CONTINUE + IF (K <= MAXORB) THEN + IF (EL(K) /= EL1) THEN + K = K + 1 + IF (K > NWFD) THEN + WRITE (0, '(A,I4)') ' TOO MANY ELECTRONS: MAX =', NWFD + GO TO 2 + ELSE + GO TO 17 + ENDIF + ENDIF + ELSE ! ! ------------ A new electron has been found; add it to the list ! - MAXORB = K - EL(MAXORB) = EL1 - READ (STRING(J+4:J+7), '(F4.0)') SUM(K) - ENDIF - J = J + 10 - IF (J < 50) GO TO 16 - ENDIF + MAXORB = K + EL(MAXORB) = EL1 + READ (STRING(J+4:J+7), '(F4.0)') SUM(K) + ENDIF + J = J + 10 + IF (J < 50) GO TO 16 + ENDIF ! ! ----- The list of electrons has been determined ! - WRITE (0, 19) MAXORB, (EL(J),J=1,MAXORB) - 19 FORMAT(/,' There are ',I3,' orbitals as follows:'/(1X,18(1X,A3))) - NWF = MAXORB - IF (NIT < 0) NIT = NWF - 21 CONTINUE + WRITE (0, 19) MAXORB, (EL(J),J=1,MAXORB) + 19 FORMAT(/,' There are ',I3,' orbitals as follows:'/(1X,18(1X,A3))) + NWF = MAXORB + IF (NIT < 0) NIT = NWF + 21 CONTINUE WRITE (0, '(/A,A)') ' Orbitals to be varied: ', & - 'ALL/NONE/=i (last i)/comma delimited list/H' - READ (5, '(A)') STRING - IF (STRING(1:1)=='h' .OR. STRING(1:1)=='H') THEN - CALL HELP (1) - GO TO 21 - ELSE IF (STRING(1:3)=='ALL' .OR. STRING(1:3)=='all') THEN - NIT = NWF - ELSE IF (STRING(1:4)=='NONE' .OR. STRING(1:4)=='none') THEN - NIT = 0 - ELSE IF (INDEX(STRING,'=') /= 0) THEN - J = INDEX(STRING,'=') - JJ = INDEX(STRING,' ') - READ (STRING(J+1:), '(I2)') NIT - IF (JJ == J + 2) NIT = MOD(NIT,10) - ELSE - NIT = 0 - J = 1 - 22 CONTINUE - NEXT = INDEX(STRING(J:),',') + 'ALL/NONE/=i (last i)/comma delimited list/H' + READ (5, '(A)') STRING + IF (STRING(1:1)=='h' .OR. STRING(1:1)=='H') THEN + CALL HELP (1) + GO TO 21 + ELSE IF (STRING(1:3)=='ALL' .OR. STRING(1:3)=='all') THEN + NIT = NWF + ELSE IF (STRING(1:4)=='NONE' .OR. STRING(1:4)=='none') THEN + NIT = 0 + ELSE IF (INDEX(STRING,'=') /= 0) THEN + J = INDEX(STRING,'=') + JJ = INDEX(STRING,' ') + READ (STRING(J+1:), '(I2)') NIT + IF (JJ == J + 2) NIT = MOD(NIT,10) + ELSE + NIT = 0 + J = 1 + 22 CONTINUE + NEXT = INDEX(STRING(J:),',') ! ! *** Search for last electron label which need not be followed ! by a comma ! IF (NEXT==0 .AND. STRING(J:J+2)/=' ') NEXT = INDEX(STRING(J+1:),' ')& - + 1 - IF (NEXT >= 1) THEN - IF (NEXT == 4) THEN - EL1 = STRING(J:J+2) - ELSE IF (NEXT == 3) THEN - EL1 = ' '//STRING(J:J+1) - ELSE - WRITE (0, *) 'Electron labels must be separated by commas;' - WRITE (0, *) ' each label must contain 2 or 3 characters' - GO TO 21 - ENDIF - CALL REORD (EL, EL1, NWF, IERR) - IF (IERR == 0) THEN - NIT = NIT + 1 - J = J + NEXT - IF (J < 72) GO TO 22 - ELSE + + 1 + IF (NEXT >= 1) THEN + IF (NEXT == 4) THEN + EL1 = STRING(J:J+2) + ELSE IF (NEXT == 3) THEN + EL1 = ' '//STRING(J:J+1) + ELSE + WRITE (0, *) 'Electron labels must be separated by commas;' + WRITE (0, *) ' each label must contain 2 or 3 characters' + GO TO 21 + ENDIF + CALL REORD (EL, EL1, NWF, IERR) + IF (IERR == 0) THEN + NIT = NIT + 1 + J = J + NEXT + IF (J < 72) GO TO 22 + ELSE WRITE (0, *) ' Case must match as well as position of', & - ' imbedded blanks' + ' imbedded blanks' WRITE (0, *) ' For 3rd character of label to be blank', & - ' follow blank with comma' - - GO TO 21 - ENDIF - ENDIF - ENDIF -! - IB = NWF - NIT + 1 - IF (NIT /= 0) THEN - 23 CONTINUE - WRITE (0, '(/A)') ' Default electron parameters ? (Y/N/H) ' + ' follow blank with comma' + + GO TO 21 + ENDIF + ENDIF + ENDIF +! + IB = NWF - NIT + 1 + IF (NIT /= 0) THEN + 23 CONTINUE + WRITE (0, '(/A)') ' Default electron parameters ? (Y/N/H) ' READ(5,'(A)') ANS - IF (ANS=='H' .OR. ANS=='h') THEN - CALL HELP (2) - GO TO 23 - ENDIF - ELSE - ANS = 'Y' - ENDIF + IF (ANS=='H' .OR. ANS=='h') THEN + CALL HELP (2) + GO TO 23 + ENDIF + ELSE + ANS = 'Y' + ENDIF IF (ANS/='Y' .AND. ANS/='y') WRITE (0, '(A,A)') & - ' S, IND, METH, ACC for non-closed Shell electrons: ' - DO I = NCLOSD + 1, NWF - IF (ANS=='Y' .OR. ANS=='y') THEN - S(I) = SS + (SUM(I)-D1)/D2 - SS = SS + SUM(I) - METH(I) = 1 - ACC(I) = D0 - IND(I) = 0 - IF (IUF /= 0) IND(I) = -1 - ELSE - WRITE (0, '(A,A)') EL(I), ': ' - READ (5, *) S(I), IND(I), METH(I), ACC(I) - ENDIF - J = 2 - IF (EL(I)(1:1) == ' ') J = 3 + ' S, IND, METH, ACC for non-closed Shell electrons: ' + DO I = NCLOSD + 1, NWF + IF (ANS=='Y' .OR. ANS=='y') THEN + S(I) = SS + (SUM(I)-D1)/D2 + SS = SS + SUM(I) + METH(I) = 1 + ACC(I) = D0 + IND(I) = 0 + IF (IUF /= 0) IND(I) = -1 + ELSE + WRITE (0, '(A,A)') EL(I), ': ' + READ (5, *) S(I), IND(I), METH(I), ACC(I) + ENDIF + J = 2 + IF (EL(I)(1:1) == ' ') J = 3 L(I) = LVAL(EL(I)(J:J)) N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 - IF (IND(I) == 1) CYCLE - EK(I) = D0 - AZ(I) = D0 - END DO + IF (IND(I) == 1) CYCLE + EK(I) = D0 + AZ(I) = D0 + END DO ! ! ***** DEFINE ALL ORBITALS IN THE CONFIGURATION TO BE ORTHOGONAL ! - DO I = 1, NWF - E(I,I) = D0 - E(I,:I-1) = D0 - WHERE (L(I) == L(:I-1)) - E(I,:I-1) = 1.D-5 - END WHERE - E(:I-1,I) = E(I,:I-1) - END DO - IB = NWF - NIT + 1 - NO = NOD - ND = NO - 2 - STRONG = .FALSE. - WRITE (3, 62) ATOM, TERM, Z, (EL(I),INT(SUM(I)),I=1,NCLOSD) + DO I = 1, NWF + E(I,I) = D0 + E(I,:I-1) = D0 + WHERE (L(I) == L(:I-1)) + E(I,:I-1) = 1.D-5 + END WHERE + E(:I-1,I) = E(I,:I-1) + END DO + IB = NWF - NIT + 1 + NO = NOD + ND = NO - 2 + STRONG = .FALSE. + WRITE (3, 62) ATOM, TERM, Z, (EL(I),INT(SUM(I)),I=1,NCLOSD) 62 FORMAT('1'/,/,/,9X,'HARTREE-FOCK WAVE FUNCTIONS FOR ',2A6,' Z =',F5.1,/,& - /,14X,'Core =',5(1X,A3,'(',I4,')'),/(20X,5(1X,A3,'(',I4,')'))) - WRITE (3, '(5X,A15,A50)') 'Configuration =', CONFIG - WRITE (3, 71) + /,14X,'Core =',5(1X,A3,'(',I4,')'),/(20X,5(1X,A3,'(',I4,')'))) + WRITE (3, '(5X,A15,A50)') 'Configuration =', CONFIG + WRITE (3, 71) 71 FORMAT(/,/,9X,'INPUT DATA'/,9X,'----- ----'/,/,13X,'WAVE FUNCTION',& - ' PROCEDURE'/,17X,'NL SIGMA METH ACC OPT'/,/,/) - DO I = 1, NWF - WRITE (3, 78) I, EL(I), N(I), L(I), S(I), METH(I), ACC(I), IND(I) - 78 FORMAT(I8,2X,A3,2I3,F7.1,I4,F4.1,I4) - END DO - OMIT = .NOT.STRONG + ' PROCEDURE'/,17X,'NL SIGMA METH ACC OPT'/,/,/) + DO I = 1, NWF + WRITE (3, 78) I, EL(I), N(I), L(I), S(I), METH(I), ACC(I), IND(I) + 78 FORMAT(I8,2X,A3,2I3,F7.1,I4,F4.1,I4) + END DO + OMIT = .NOT.STRONG ! - CALL ARRAY - CALL ENEXPR (TERM, DONE) - IF (.NOT.DONE) THEN + CALL ARRAY + CALL ENEXPR (TERM, DONE) + IF (.NOT.DONE) THEN ! ! --- Case needs additional data ! - WRITE (0, 85) + WRITE (0, 85) 85 FORMAT(/,' The program could not derive the energy expression'/,& ' Select one of the following options and enter:'/,& ' 1 Re-enter the term and configuration'/,& - ' 2 Enter the deviations from Eav as input'/,' 3 STOP'/) - READ (5, *) ISELEC - GO TO (5,86,99) ISELEC - 86 CONTINUE - WRITE (0, 83) + ' 2 Enter the deviations from Eav as input'/,' 3 STOP'/) + READ (5, *) ISELEC + GO TO (5,86,99) ISELEC + 86 CONTINUE + WRITE (0, 83) 83 FORMAT(/,' Input data for deviations from the average energy'/,& ' First FK integrals, then GK integrals in indicated format'/,& ' cc.ccccccccccFkk(el1,el2) - terminate each list with an *',& - ' in the F column') - FIRST = .TRUE. + ' in the F column') + FIRST = .TRUE. ! ! ***** READ 'FK' AND 'GK' CARDS, OMITTING THE HEADER IF A FILE ! - 82 CONTINUE - READ (5, 84) CFG, W, KFG, EL1, EL2 - 84 FORMAT(F14.8,A1,I2,1X,A3,1X,A3) - IF (W /= ASTER) THEN - CALL EPTR (EL, EL1, IFG, J1) - IF (J1 == 1) GO TO 99 - CALL EPTR (EL, EL2, JFG, J2) - IF (J2 == 1) GO TO 99 - CALL ADD (CFG, KFG, IFG, JFG, FIRST) - CALL ADD (CFG, KFG, JFG, IFG, FIRST) - GO TO 82 - ELSE IF (FIRST) THEN - FIRST = .FALSE. - GO TO 82 - ENDIF - ENDIF + 82 CONTINUE + READ (5, 84) CFG, W, KFG, EL1, EL2 + 84 FORMAT(F14.8,A1,I2,1X,A3,1X,A3) + IF (W /= ASTER) THEN + CALL EPTR (EL, EL1, IFG, J1) + IF (J1 == 1) GO TO 99 + CALL EPTR (EL, EL2, JFG, J2) + IF (J2 == 1) GO TO 99 + CALL ADD (CFG, KFG, IFG, JFG, FIRST) + CALL ADD (CFG, KFG, JFG, IFG, FIRST) + GO TO 82 + ELSE IF (FIRST) THEN + FIRST = .FALSE. + GO TO 82 + ENDIF + ENDIF ! ! ***** COMPUTE THE INITIAL ARRAY AND INITIAL RADIAL FUNCTIONS ! - CALL WAVEFN + CALL WAVEFN ! ! ... Define an order for the functions to be iterated ! - DO JP = 1, NWF - IORD(JP) = JP - END DO - 91 CONTINUE - ORDERD = .TRUE. - DO JP = IB, NWF - 1 - N1 = N(IORD(JP)) - L1 = L(IORD(JP)) - N2 = N(IORD(JP+1)) - L2 = L(IORD(JP+1)) - IF (.NOT.(N1>N2 .OR. N1==N2 .AND. L1>L2)) CYCLE - ITEMP = IORD(JP) - IORD(JP) = IORD(JP+1) - IORD(JP+1) = ITEMP - ORDERD = .FALSE. - END DO - IF (.NOT.ORDERD) GO TO 91 - RETURN - 99 CONTINUE - STOP - END SUBROUTINE DATA + DO JP = 1, NWF + IORD(JP) = JP + END DO + 91 CONTINUE + ORDERD = .TRUE. + DO JP = IB, NWF - 1 + N1 = N(IORD(JP)) + L1 = L(IORD(JP)) + N2 = N(IORD(JP+1)) + L2 = L(IORD(JP+1)) + IF (.NOT.(N1>N2 .OR. N1==N2 .AND. L1>L2)) CYCLE + ITEMP = IORD(JP) + IORD(JP) = IORD(JP+1) + IORD(JP+1) = ITEMP + ORDERD = .FALSE. + END DO + IF (.NOT.ORDERD) GO TO 91 + RETURN + 99 CONTINUE + STOP + END SUBROUTINE DATA ! ! ------------------------------------------------------------------ ! D E @@ -1818,171 +1818,171 @@ END SUBROUTINE DATA ! is set to 2. ! ! - SUBROUTINE DE(I1) + SUBROUTINE DE(I1) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE de_C - USE TEST_C - USE COEFF_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: PDE, E, SUM, DPM, ACC, METH, IPR - USE LABEL_C, ONLY: EL + USE TEST_C + USE COEFF_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: PDE, E, SUM, DPM, ACC, METH, IPR + USE LABEL_C, ONLY: EL !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE methd1_I - USE quad_I - USE quadr_I - USE orthog_I - USE grange_I + USE methd1_I + USE quad_I + USE quadr_I + USE orthog_I + USE grange_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I1 + INTEGER , INTENT(IN) :: I1 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, NN, IJ, JJ - REAL(DOUBLE) :: ED2, PN, ED1, CD, DP, DIFF, DPW, PNN - LOGICAL :: CHANGE + INTEGER :: I, J, NN, IJ, JJ + REAL(DOUBLE) :: ED2, PN, ED1, CD, DP, DIFF, DPW, PNN + LOGICAL :: CHANGE CHARACTER(LEN=3), DIMENSION(3) :: ASTER = (/ ' ', '* ', '**'/) !----------------------------------------------- ! - I = I1 - ED2 = E(I,I) - KK = MAX0(1,METH(I)) - IF (NWF == 1) KK = 2 - NODE = N(I) - L(I) - 1 + I = I1 + ED2 = E(I,I) + KK = MAX0(1,METH(I)) + IF (NWF == 1) KK = 2 + NODE = N(I) - L(I) - 1 ! ! ***** CALL METHD1 TO SOLVE THE DIFFERENTIAL EQUATION ! - CALL METHD1 (I) - IF (FAIL) GO TO 25 + CALL METHD1 (I) + IF (FAIL) GO TO 25 ! - 12 CONTINUE - PN = DSQRT(QUAD(I,M,PDE,PDE)) - PDE(:M) = PDE(:M)/PN - AZZ = AZZ/PN + 12 CONTINUE + PN = DSQRT(QUAD(I,M,PDE,PDE)) + PDE(:M) = PDE(:M)/PN + AZZ = AZZ/PN ! ! ***** CHECK IF DIFFERENT METHOD SHOULD BE USED ! - IF (KK == 1) THEN + IF (KK == 1) THEN IF (DABS(D1 - ED2/E(I,I))<0.005D0 .AND. DMAX1(DABS(D1-PN),DABS(D1/PN-& - D1))>0.20D0) THEN - METH(I) = 2 - KK = 2 - GO TO 25 - ENDIF - ELSE - IF (DABS(D1 - ED2/E(I,I))<0.0001D0 .AND. IC>1) IC = IC - 1 - ENDIF + D1))>0.20D0) THEN + METH(I) = 2 + KK = 2 + GO TO 25 + ENDIF + ELSE + IF (DABS(D1 - ED2/E(I,I))<0.0001D0 .AND. IC>1) IC = IC - 1 + ENDIF ! ! ***** SET THE ACCELERATING PARAMETER ! - IF (IPR /= I) THEN - ACC(I) = 0.75*ACC(I) - ELSE - ED2 = ED2 - E(I,I) - IF (ED1*ED2 > D0) THEN - ACC(I) = 0.75*ACC(I) - ELSE - ACC(I) = (D1 + D3*ACC(I))/D4 - ENDIF - ENDIF - C = ACC(I) - CD = D1 - C + IF (IPR /= I) THEN + ACC(I) = 0.75*ACC(I) + ELSE + ED2 = ED2 - E(I,I) + IF (ED1*ED2 > D0) THEN + ACC(I) = 0.75*ACC(I) + ELSE + ACC(I) = (D1 + D3*ACC(I))/D4 + ENDIF + ENDIF + C = ACC(I) + CD = D1 - C ! ! ***** IMPROVE THE ESTIMATES ! - MAX(I) = M - DP = D0 - DO J = 1, M - DIFF = P(J,I) - PDE(J) - DP = DMAX1(DP,DABS(DIFF)*R2(J)) - P(J,I) = PDE(J) + C*DIFF - END DO - IF (M /= NO) THEN - M = M + 1 - P(M:NO,I) = D0 - AZ(I) = CD*AZZ + C*AZ(I) - AZZ = AZ(I) - ENDIF + MAX(I) = M + DP = D0 + DO J = 1, M + DIFF = P(J,I) - PDE(J) + DP = DMAX1(DP,DABS(DIFF)*R2(J)) + P(J,I) = PDE(J) + C*DIFF + END DO + IF (M /= NO) THEN + M = M + 1 + P(M:NO,I) = D0 + AZ(I) = CD*AZZ + C*AZ(I) + AZZ = AZ(I) + ENDIF ! ! ***** CHECK THE ORTHOGONALIZATION ! - NN = NWF - IF (OMIT) NN = IB - 1 - IJ = 0 - DPW = DP/DSQRT(SUM(I)) - M = MAX(I) - CHANGE = .FALSE. - DO J = 1, NN - IF (E(I,J)==D0 .OR. I==J) CYCLE - IF (DPM(J)>=DSQRT(SUM(J))*DPW .AND. J>=IB) CYCLE + NN = NWF + IF (OMIT) NN = IB - 1 + IJ = 0 + DPW = DP/DSQRT(SUM(I)) + M = MAX(I) + CHANGE = .FALSE. + DO J = 1, NN + IF (E(I,J)==D0 .OR. I==J) CYCLE + IF (DPM(J)>=DSQRT(SUM(J))*DPW .AND. J>=IB) CYCLE ! ! ORTHOGONALITY CONDITION APPLIES ! - C = QUADR(I,J,0) - WRITE (6, 63) EL(J), EL(I), C - 63 FORMAT(6X,'<',A3,'|',A3,'>=',1P,D8.1) - M = MAX0(M,MAX(J)) - P(:M,I) = P(:M,I) - C*P(:M,J) - AZZ = AZZ - C*AZ(J) - CHANGE = .TRUE. - END DO - IF (CHANGE .OR. C/=D0) THEN - PNN = DSQRT(QUADR(I,I,0)) - P(:M,I) = P(:M,I)/PNN - AZZ = AZZ/PNN - ENDIF - M = NO - 67 CONTINUE - IF (DABS(P(M,I)) < 1.D-15) THEN - P(M,I) = D0 - M = M - 1 - GO TO 67 - ENDIF - MAX(I) = M - IF (AZZ > D0) AZ(I) = DMAX1(AZZ,D5*AZ(I)) - WRITE (6, 17) EL(I), E(I,I), AZ(I), PN, ASTER(KK), DP - 17 FORMAT(20X,A3,2F15.7,F12.7,A2,1P,D10.2) - DPM(I) = DP - IF (IPR == I1) THEN - ED1 = ED2 - ELSE - ED1 = ED2 - E(I1,I1) - ENDIF - IPR = I1 - RETURN + C = QUADR(I,J,0) + WRITE (6, 63) EL(J), EL(I), C + 63 FORMAT(6X,'<',A3,'|',A3,'>=',1P,D8.1) + M = MAX0(M,MAX(J)) + P(:M,I) = P(:M,I) - C*P(:M,J) + AZZ = AZZ - C*AZ(J) + CHANGE = .TRUE. + END DO + IF (CHANGE .OR. C/=D0) THEN + PNN = DSQRT(QUADR(I,I,0)) + P(:M,I) = P(:M,I)/PNN + AZZ = AZZ/PNN + ENDIF + M = NO + 67 CONTINUE + IF (DABS(P(M,I)) < 1.D-15) THEN + P(M,I) = D0 + M = M - 1 + GO TO 67 + ENDIF + MAX(I) = M + IF (AZZ > D0) AZ(I) = DMAX1(AZZ,D5*AZ(I)) + WRITE (6, 17) EL(I), E(I,I), AZ(I), PN, ASTER(KK), DP + 17 FORMAT(20X,A3,2F15.7,F12.7,A2,1P,D10.2) + DPM(I) = DP + IF (IPR == I1) THEN + ED1 = ED2 + ELSE + ED1 = ED2 - E(I1,I1) + ENDIF + IPR = I1 + RETURN ! ! ***** IF METHD1 FAILED TO FIND AN ACCEPTABLE SOLUTION, ORTHOGONALIZE ! ***** THE ESTIMATES AND TRY AGAIN ! - 25 CONTINUE - IF (I /= IB) THEN - CALL ORTHOG - CALL GRANGE - ENDIF - 27 CONTINUE - CALL METHD1 (I) - IF (FAIL) THEN + 25 CONTINUE + IF (I /= IB) THEN + CALL ORTHOG + CALL GRANGE + ENDIF + 27 CONTINUE + CALL METHD1 (I) + IF (FAIL) THEN ! ! ***** ERROR RETURN FROM SECOND TRY. IF M1 WAS USED,SWITCH TO ! M2 AND TRY ONCE MORE. ! - IF (KK == 2) RETURN - KK = 2 - GO TO 27 - ELSE - GO TO 12 - ENDIF - RETURN - END SUBROUTINE DE + IF (KK == 2) RETURN + KK = 2 + GO TO 27 + ELSE + GO TO 12 + ENDIF + RETURN + END SUBROUTINE DE ! ! ------------------------------------------------------------------ ! D E V @@ -1991,59 +1991,59 @@ END SUBROUTINE DE ! Add the deviations to the average energy for a partially filled ! p- or d- shell ! - SUBROUTINE DEV(IEL, L, Q, I, DONE) + SUBROUTINE DEV(IEL, L, Q, I, DONE) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE -!...Translated by Pacific-Sierra Research 77to90 4.3E 17:25:54 12/28/06 -!...Switches: + USE vast_kind_param, ONLY: DOUBLE +!...Translated by Pacific-Sierra Research 77to90 4.3E 17:25:54 12/28/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE add_I + USE add_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IEL - INTEGER , INTENT(IN) :: L - INTEGER , INTENT(INOUT) :: I - REAL(DOUBLE) , INTENT(IN) :: Q - LOGICAL , INTENT(OUT) :: DONE + INTEGER :: IEL + INTEGER , INTENT(IN) :: L + INTEGER , INTENT(INOUT) :: I + REAL(DOUBLE) , INTENT(IN) :: Q + LOGICAL , INTENT(OUT) :: DONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(6) :: F2PP = (/ -3, 3, 12, -9, 0, 6/) + INTEGER , DIMENSION(6) :: F2PP = (/ -3, 3, 12, -9, 0, 6/) INTEGER , DIMENSION(45) :: F2DD = & (/ -58, 77, 50, -13, 140, -93, 42, -12, -57, 123, 105, 69, -12, & -105, -69, -24, 66, 12, 39, 21, 57, -51, 30, 48, 84, 219, & 111, 210, 138, -175, -85, 23, -22, -112, -76, -58, 167, 23, & - -85, 59, 140, 104, 86, 320, 113/) + -85, 59, 140, 104, 86, 320, 113/) INTEGER , DIMENSION(45) :: F4DD = & (/ 5, -70, 15, 50, 140, -30, -105, 30, 55, -45, 105, -15, 30, & -105, 15, -10, 45, -30, -45, 70, -55, 75, 135, 20, 0, 30, -15,& 210, -30, -175, -50, -40, -85, 35, 50, 110, -15, -5, 125, & -25, 140, 20, -40, -100, -55/) - INTEGER :: N -!----------------------------------------------- -! - DONE = .TRUE. - N = Q - IF (N > 2*L + 1) N = 4*L + 2 - N - IF (N > 1) THEN - IF (L == 1) THEN - CALL ADD (2*F2PP(I)/25.D0, 2, IEL, IEL, .TRUE.) - ELSE IF (L == 2) THEN - I = I - 6 - CALL ADD (2*F2DD(I)/441.D0, 2, IEL, IEL, .TRUE.) - CALL ADD (2*F4DD(I)/441.D0, 4, IEL, IEL, .TRUE.) - ELSE - DONE = .FALSE. - ENDIF - ENDIF - RETURN - END SUBROUTINE DEV + INTEGER :: N +!----------------------------------------------- +! + DONE = .TRUE. + N = Q + IF (N > 2*L + 1) N = 4*L + 2 - N + IF (N > 1) THEN + IF (L == 1) THEN + CALL ADD (2*F2PP(I)/25.D0, 2, IEL, IEL, .TRUE.) + ELSE IF (L == 2) THEN + I = I - 6 + CALL ADD (2*F2DD(I)/441.D0, 2, IEL, IEL, .TRUE.) + CALL ADD (2*F4DD(I)/441.D0, 4, IEL, IEL, .TRUE.) + ELSE + DONE = .FALSE. + ENDIF + ENDIF + RETURN + END SUBROUTINE DEV ! ! ------------------------------------------------------------------ ! D Y K @@ -2057,55 +2057,55 @@ END SUBROUTINE DEV ! which enter into the spin-orbit calculation. ! ! - SUBROUTINE DYK(I, J, K) + SUBROUTINE DYK(I, J, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I, J, K + INTEGER , INTENT(IN) :: I, J, K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: JJ, M, MM - REAL(DOUBLE) :: DEN, FACT, A, AA, F1, F2, F3, C, HH -!----------------------------------------------- - DEN = L(I) + L(J) + 2 + K - FACT = L(J) - YK(:2) = FACT*P(:2,I)*P(:2,J)*R(:2)/DEN - A = EH**K - AA = A*A - A = D4*A - F1 = FACT*P(1,I)*P(1,J)*R(1) - F2 = FACT*P(2,I)*P(2,J)*R(2) - DO M = 3, ND - F3 = ((-P(M+2,J))+D8*(P(M+1,J)-P(M-1,J))+P(M-2,J))/(D6*H) - F3 = D5*P(M,I)*(F3 - P(M,J))*R(M) - YK(M) = YK(M-2)*AA + H3*(F3 + A*F2 + AA*F1) - F1 = F2 - F2 = F3 - END DO - A = A*EH**3 - AA = A*A/D16 - C = 2*K + 3 - HH = C*H3 - YK(NO) = YK(ND) - F1 = YK(NO) - F2 = F1 - DO MM = 3, NO - M = NO - MM + 1 - F3 = YK(M) - YK(M) = YK(M+2)*AA + HH*(F3 + A*F2 + AA*F1) - F1 = F2 - F2 = F3 - END DO - RETURN - END SUBROUTINE DYK + INTEGER :: JJ, M, MM + REAL(DOUBLE) :: DEN, FACT, A, AA, F1, F2, F3, C, HH +!----------------------------------------------- + DEN = L(I) + L(J) + 2 + K + FACT = L(J) + YK(:2) = FACT*P(:2,I)*P(:2,J)*R(:2)/DEN + A = EH**K + AA = A*A + A = D4*A + F1 = FACT*P(1,I)*P(1,J)*R(1) + F2 = FACT*P(2,I)*P(2,J)*R(2) + DO M = 3, ND + F3 = ((-P(M+2,J))+D8*(P(M+1,J)-P(M-1,J))+P(M-2,J))/(D6*H) + F3 = D5*P(M,I)*(F3 - P(M,J))*R(M) + YK(M) = YK(M-2)*AA + H3*(F3 + A*F2 + AA*F1) + F1 = F2 + F2 = F3 + END DO + A = A*EH**3 + AA = A*A/D16 + C = 2*K + 3 + HH = C*H3 + YK(NO) = YK(ND) + F1 = YK(NO) + F2 = F1 + DO MM = 3, NO + M = NO - MM + 1 + F3 = YK(M) + YK(M) = YK(M+2)*AA + HH*(F3 + A*F2 + AA*F1) + F1 = F2 + F2 = F3 + END DO + RETURN + END SUBROUTINE DYK ! ! ------------------------------------------------------------------ ! E K I N @@ -2119,35 +2119,35 @@ END SUBROUTINE DYK ! integrated with respect to r. ! ! - REAL(KIND(0.0D0)) FUNCTION EKIN (I, II, REL) + REAL(KIND(0.0D0)) FUNCTION EKIN (I, II, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE RADIAL_C - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE RADIAL_C + USE PARAM_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE xch_I - USE potl_I - USE quads_I - USE quad_I + USE xch_I + USE potl_I + USE quads_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: II - LOGICAL :: REL + INTEGER :: I + INTEGER :: II + LOGICAL :: REL !----------------------------------------------- - CALL XCH (I, 2) - CALL POTL (I, REL) - YK(:NO) = YR(:NO) - YR(:NO) = P(:NO,II) - EKIN = D2*QUADS(I,II,1) + QUAD(II,NO,YR,X) - RETURN - END FUNCTION EKIN + CALL XCH (I, 2) + CALL POTL (I, REL) + YK(:NO) = YR(:NO) + YR(:NO) = P(:NO,II) + EKIN = D2*QUADS(I,II,1) + QUAD(II,NO,YR,X) + RETURN + END FUNCTION EKIN ! ! ------------------------------------------------------------------ ! E N E R G Y @@ -2155,63 +2155,63 @@ END FUNCTION EKIN ! ! Determines the position of the electron in the electron list ! - SUBROUTINE ENERGY(ETOTAL) + SUBROUTINE ENERGY(ETOTAL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE LABEL_C - USE RADIAL_C, ONLY: L, NOD - USE WAVE_C, ONLY: EK, SUM - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE LABEL_C + USE RADIAL_C, ONLY: L, NOD + USE WAVE_C, ONLY: EK, SUM + USE PARAM_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE hl_I - USE a_I - USE fk_I - USE b_I - USE gk_I + USE hl_I + USE a_I + USE fk_I + USE b_I + USE gk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(OUT) :: ETOTAL + REAL(DOUBLE) , INTENT(OUT) :: ETOTAL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, K - REAL(DOUBLE) :: C + INTEGER :: I, J, K + REAL(DOUBLE) :: C !----------------------------------------------- ! ! ***** COMPUTE KINETIC ENERGY IF NECESSARY ! - DO I = 1, NWF - EK(I) = -D5*HL(EL,I,I,REL) - END DO -! - ETOTAL = D0 - DO I = 1, NWF - ETOTAL = ETOTAL + SUM(I)*EK(I) - DO J = 1, I - DO K = 0, 2*MIN0(L(I),L(J)), 2 - C = A(I,J,K)*SUM(I) - IF (I == J) C = C/D2 - IF (ABS(C) == D0) CYCLE - ETOTAL = ETOTAL + C*FK(I,J,K,REL) - END DO - END DO - DO J = 1, I - 1 - DO K = ABS(L(I)-L(J)), L(I) + L(J), 2 - C = B(I,J,K)*SUM(I) - IF (ABS(C) == D0) CYCLE - ETOTAL = ETOTAL + C*GK(I,J,K,REL) - END DO - END DO - END DO - RETURN - END SUBROUTINE ENERGY + DO I = 1, NWF + EK(I) = -D5*HL(EL,I,I,REL) + END DO +! + ETOTAL = D0 + DO I = 1, NWF + ETOTAL = ETOTAL + SUM(I)*EK(I) + DO J = 1, I + DO K = 0, 2*MIN0(L(I),L(J)), 2 + C = A(I,J,K)*SUM(I) + IF (I == J) C = C/D2 + IF (ABS(C) == D0) CYCLE + ETOTAL = ETOTAL + C*FK(I,J,K,REL) + END DO + END DO + DO J = 1, I - 1 + DO K = ABS(L(I)-L(J)), L(I) + L(J), 2 + C = B(I,J,K)*SUM(I) + IF (ABS(C) == D0) CYCLE + ETOTAL = ETOTAL + C*GK(I,J,K,REL) + END DO + END DO + END DO + RETURN + END SUBROUTINE ENERGY ! ! ------------------------------------------------------------------ ! E N E X P R @@ -2224,50 +2224,50 @@ END SUBROUTINE ENERGY ! iv) an s-electron and an open p- or d-shell ! v) an open p-shell and a single electron, any l ! - SUBROUTINE ENEXPR(TERM, DONE) + SUBROUTINE ENEXPR(TERM, DONE) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE WAVE_C - USE RADIAL_C, ONLY: L + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE WAVE_C + USE RADIAL_C, ONLY: L !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE looktm_I - USE dev_I - USE add_I - USE lval_I - USE lookup_I + USE looktm_I + USE dev_I + USE add_I + USE lval_I + USE lookup_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL :: DONE - CHARACTER , INTENT(IN) :: TERM*6 + LOGICAL :: DONE + CHARACTER , INTENT(IN) :: TERM*6 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(5) :: SUMTAB = (/ 1, 4, 7, 10, 11/) + INTEGER , DIMENSION(5) :: SUMTAB = (/ 1, 4, 7, 10, 11/) INTEGER , DIMENSION(11) :: PARTAB = & (/ 2, 3, 1, 1, 4, 2, 2, 3, 1, 1, 2/) INTEGER , DIMENSION(11) :: PTRTAB = & - (/ 6, 12, 17, 18, 20, 30, 36, 42, 47, 48, 54/) + (/ 6, 12, 17, 18, 20, 30, 36, 42, 47, 48, 54/) CHARACTER, DIMENSION(11) :: PARCH = & - (/ 'P', 'P', 'D', 'S', 'S', 'D', 'P', 'P', 'D', 'S', 'P'/) + (/ 'P', 'P', 'D', 'S', 'S', 'D', 'P', 'P', 'D', 'S', 'P'/) ! ! ... Encoded term value -- S = LTAB/10 ! Lterm = L + (LTAB mod 10 - 5) ! Example: LTAB = 36 with L = 2 is 3F - INTEGER , DIMENSION(54) :: LTAB = & + INTEGER , DIMENSION(54) :: LTAB = & (/ 36, 35, 34, 16, 15, 14, 46, 45, 44, 26, 25, 24, 27, 26, 25,& 24, 23, 25, 55, 35, 37, 36, 35, 34, 33, 17, 16, 15, 14, 13,& 36, 35, 34, 16, 15, 14, 46, 45, 44, 26, 25, 24, 27, 26, 25,& - 24, 23, 25, 36, 35, 34, 16, 15, 14/) + 24, 23, 25, 36, 35, 34, 16, 15, 14/) INTEGER , DIMENSION(11) :: PLVAL = & - (/ 1, 1, 2, 0, 0, 2, 1, 1, 2, 0, 1/) - INTEGER :: PACVAL, SP, PS1, PS2 + (/ 1, 1, 2, 0, 0, 2, 1, 1, 2, 0, 1/) + INTEGER :: PACVAL, SP, PS1, PS2 ! ! ... FINT, GINT1, and GINT2 are coefficients of Slater integrals ! in l, tabulated by Slater, @@ -2285,7 +2285,7 @@ SUBROUTINE ENEXPR(TERM, DONE) -4, -4, 3, 2, 5, 3, 2, -1, 0, -4, -4, 3, 2, 5, 3, -4, 2, 0, & 2, 11, -6, 4, 4, -15, 2, -7, -15, -4, -10, -6, 0, 0, 0, -2, & 1, 0, 4, 4, -3, -2, -5, -3, -2, 1, 0, 4, 4, -3, -2, -5, -3/)& - , (/ 3, 54/) ) + , (/ 3, 54/) ) ! ! ... coefficients of G(l-1) integrals ! @@ -2299,7 +2299,7 @@ SUBROUTINE ENEXPR(TERM, DONE) 0, -6, 3, 12, 6, 3, -4, 2, 0, -4, 2, 0, -4, 2, 0, -4, 2, 0, & 14, 11, -9, 14, -7, -9, -4, -2, 0, -4, 2, 0, -2, 7, 3, 2, 11,& 3, 8, 8, 0, 0, 0, 0, -2, 1, 0, -2, 1, 0, -2, 1, 0, -2, 1, 0,& - -2, 1, 0, 22, 13, 0/), (/ 3, 54 /) ) + -2, 1, 0, 22, 13, 0/), (/ 3, 54 /) ) ! ! ... coefficients of G(l+1) integrals ! @@ -2314,224 +2314,224 @@ SUBROUTINE ENEXPR(TERM, DONE) -10, -6, -4, -10, -6, -4, -10, -6, 14, 35, 12, 14, 17, -6, -4,& -10, -6, 8, 8, 0, 2, -7, -6, -2, -11, -6, -4, -10, -6, -4, & -10, -6, 0, 0, 0, -2, -5, -3, -2, -5, -3, -2, -5, -3, 22, 31, & - 9, -2, -5, -3, -2, -5, -3/), (/ 3, 54/) ) - INTEGER , DIMENSION(2) :: NOS + 9, -2, -5, -3, -2, -5, -3/), (/ 3, 54/) ) + INTEGER , DIMENSION(2) :: NOS INTEGER :: IP, IL, IS, J, I, IIS, IIL, NSL, IPM, NSLM, IPP, NSLP,& - ISUMP, NL, LP, IPTR1, IPTR2, NOMACH, IND, LV - REAL(DOUBLE) :: C, CSP, VAL1, VAL2, VAL3 - CHARACTER :: SL*2, SENOR, PSL*2, SLM*2, SLP*2 + ISUMP, NL, LP, IPTR1, IPTR2, NOMACH, IND, LV + REAL(DOUBLE) :: C, CSP, VAL1, VAL2, VAL3 + CHARACTER :: SL*2, SENOR, PSL*2, SLM*2, SLP*2 !----------------------------------------------- ! - IP = 1 - 1 CONTINUE - IF (TERM(IP:IP) == ' ') THEN - IP = IP + 1 - GO TO 1 - ENDIF - SL = TERM(IP:IP+1) - SENOR = ' ' - IF (IP <= 4) SENOR = TERM(IP+2:IP+2) + IP = 1 + 1 CONTINUE + IF (TERM(IP:IP) == ' ') THEN + IP = IP + 1 + GO TO 1 + ENDIF + SL = TERM(IP:IP+1) + SENOR = ' ' + IF (IP <= 4) SENOR = TERM(IP+2:IP+2) ! ! --- convert lowercase L symbol to uppercase ! IF (SL(2:2)>'a' .AND. SL(2:2)<'z') SL(2:2) = CHAR(ICHAR(SL(2:2))+ICHAR(& - 'A')-ICHAR('a')) + 'A')-ICHAR('a')) ! ! --- determine if FK or GK data needs to be input ! - IL = 0 - IS = 0 - J = 1 - IF (SL/='AV' .AND. SL/='aV') THEN - DO I = NCLOSD + 1, NWF - IF (SUM(I)==4*L(I) + 2 .OR. SUM(I)==0.D0) CYCLE - IF (J > 2) THEN - DONE = .FALSE. - RETURN - ENDIF - NOS(J) = I - J = J + 1 - IF (L(I)==0 .AND. IS==0) THEN - IS = IS + 1 - IIS = I - ELSE - IL = IL + 1 - IIL = I - ENDIF - END DO - ELSE - DO I = NCLOSD + 1, NWF - IF (SUM(I)==4*L(I) + 2 .OR. SUM(I)==0.D0) CYCLE - IF (J > 2) THEN - DONE = .TRUE. - RETURN - ENDIF - NOS(J) = I - J = J + 1 - IF (L(I)==0 .AND. IS==0) THEN - IS = IS + 1 - IIS = I - ELSE - IL = IL + 1 - IIL = I - ENDIF - END DO - ENDIF - IF (SL/='AV' .AND. SL/='aV' .AND. IS+IL/=0) THEN - DONE = .FALSE. - C = 0.D0 - IF (IS + IL<=2 .AND. IL<=1) THEN - IF (IS==0 .AND. IL==1) THEN - 3 CONTINUE - CALL LOOKTM (L(IIL), SL, SENOR, SUM(IIL), IP, NSL) - IF (NSL > 1) THEN - WRITE (0, *) ' Ambiguous term: enter seniority' - READ (5, '(A1)') SENOR - GO TO 3 - ENDIF - CALL DEV (IIL, L(IIL), SUM(IIL), IP, DONE) - ELSE IF (IS==1 .AND. IL==1) THEN - SLM = SL - SLP = SL - SLM(1:1) = CHAR(ICHAR(SLM(1:1))-1) - SLP(1:1) = CHAR(ICHAR(SLP(1:1))+1) - CALL LOOKTM (L(IIL), SLM, SENOR, SUM(IIL), IPM, NSLM) - CALL LOOKTM (L(IIL), SLP, SENOR, SUM(IIL), IPP, NSLP) - IF (NSLM + NSLP == 0) THEN - DONE = .FALSE. - RETURN - ELSE IF (NSLM==1 .AND. NSLP==0) THEN - SL = SLM - IP = IPM - ELSE IF (NSLM==0 .AND. NSLP==1) THEN - SL = SLP - IP = IPP - ELSE IF (NSLM==1 .AND. NSLP==1) THEN - 4 CONTINUE + IL = 0 + IS = 0 + J = 1 + IF (SL/='AV' .AND. SL/='aV') THEN + DO I = NCLOSD + 1, NWF + IF (SUM(I)==4*L(I) + 2 .OR. SUM(I)==0.D0) CYCLE + IF (J > 2) THEN + DONE = .FALSE. + RETURN + ENDIF + NOS(J) = I + J = J + 1 + IF (L(I)==0 .AND. IS==0) THEN + IS = IS + 1 + IIS = I + ELSE + IL = IL + 1 + IIL = I + ENDIF + END DO + ELSE + DO I = NCLOSD + 1, NWF + IF (SUM(I)==4*L(I) + 2 .OR. SUM(I)==0.D0) CYCLE + IF (J > 2) THEN + DONE = .TRUE. + RETURN + ENDIF + NOS(J) = I + J = J + 1 + IF (L(I)==0 .AND. IS==0) THEN + IS = IS + 1 + IIS = I + ELSE + IL = IL + 1 + IIL = I + ENDIF + END DO + ENDIF + IF (SL/='AV' .AND. SL/='aV' .AND. IS+IL/=0) THEN + DONE = .FALSE. + C = 0.D0 + IF (IS + IL<=2 .AND. IL<=1) THEN + IF (IS==0 .AND. IL==1) THEN + 3 CONTINUE + CALL LOOKTM (L(IIL), SL, SENOR, SUM(IIL), IP, NSL) + IF (NSL > 1) THEN + WRITE (0, *) ' Ambiguous term: enter seniority' + READ (5, '(A1)') SENOR + GO TO 3 + ENDIF + CALL DEV (IIL, L(IIL), SUM(IIL), IP, DONE) + ELSE IF (IS==1 .AND. IL==1) THEN + SLM = SL + SLP = SL + SLM(1:1) = CHAR(ICHAR(SLM(1:1))-1) + SLP(1:1) = CHAR(ICHAR(SLP(1:1))+1) + CALL LOOKTM (L(IIL), SLM, SENOR, SUM(IIL), IPM, NSLM) + CALL LOOKTM (L(IIL), SLP, SENOR, SUM(IIL), IPP, NSLP) + IF (NSLM + NSLP == 0) THEN + DONE = .FALSE. + RETURN + ELSE IF (NSLM==1 .AND. NSLP==0) THEN + SL = SLM + IP = IPM + ELSE IF (NSLM==0 .AND. NSLP==1) THEN + SL = SLP + IP = IPP + ELSE IF (NSLM==1 .AND. NSLP==1) THEN + 4 CONTINUE WRITE (0, '(A,A3,A,A3)') ' Ambiguous l**n term: enter', SLM, & - ' or ', SLP - READ (5, '(A2)') SL - IF (SL == SLM) THEN - IP = IPM - ELSE IF (SL == SLP) THEN - IP = IPP - ELSE - WRITE (0, *) ' Term not allowed: re-enter' - GO TO 4 - ENDIF - ELSE - 5 CONTINUE + ' or ', SLP + READ (5, '(A2)') SL + IF (SL == SLM) THEN + IP = IPM + ELSE IF (SL == SLP) THEN + IP = IPP + ELSE + WRITE (0, *) ' Term not allowed: re-enter' + GO TO 4 + ENDIF + ELSE + 5 CONTINUE WRITE (0, '(A,A)') ' Ambiguous l**n parent term:', & - 'Enter term and seniority' - READ (5, '(A2,A1)') SL, SENOR - IF (SENOR == ' ') THEN - WRITE (0, *) 'Seniority is needed' - GO TO 5 - ENDIF - CALL LOOKTM (L(IIL), SL, SENOR, SUM(IIL), IP, NSL) - IF (NSL /= 1) THEN + 'Enter term and seniority' + READ (5, '(A2,A1)') SL, SENOR + IF (SENOR == ' ') THEN + WRITE (0, *) 'Seniority is needed' + GO TO 5 + ENDIF + CALL LOOKTM (L(IIL), SL, SENOR, SUM(IIL), IP, NSL) + IF (NSL /= 1) THEN WRITE (0, '(A,A3,A,A3,A)') ' Allowed terms are ', SLM, & - ' or ', SLP, ' plus seniority' - GO TO 5 - ENDIF - ENDIF - CALL DEV (IIL, L(IIL), SUM(IIL), IP, DONE) - IF (DONE) THEN - SP = ICHAR(SL(1:1)) - ICHAR('0') - CSP = (SP - 1)/2. - IF (SL == SLM) THEN - C = -CSP/(2*L(IIL)+1) - ELSE - C = (CSP + 1)/(2*L(IIL)+1) - ENDIF - CALL ADD (C, L(IIL), IIS, IIL, .FALSE.) - CALL ADD (C, L(IIL), IIL, IIS, .FALSE.) - ENDIF - ELSE IF (IS==1 .AND. IL==0) THEN - DONE = .TRUE. - ENDIF - ELSE + ' or ', SLP, ' plus seniority' + GO TO 5 + ENDIF + ENDIF + CALL DEV (IIL, L(IIL), SUM(IIL), IP, DONE) + IF (DONE) THEN + SP = ICHAR(SL(1:1)) - ICHAR('0') + CSP = (SP - 1)/2. + IF (SL == SLM) THEN + C = -CSP/(2*L(IIL)+1) + ELSE + C = (CSP + 1)/(2*L(IIL)+1) + ENDIF + CALL ADD (C, L(IIL), IIS, IIL, .FALSE.) + CALL ADD (C, L(IIL), IIL, IIS, .FALSE.) + ENDIF + ELSE IF (IS==1 .AND. IL==0) THEN + DONE = .TRUE. + ENDIF + ELSE IF (L(NOS(1))==1 .AND. SUM(NOS(2))==1.D0 .OR. L(NOS(2))==1 .AND. & - SUM(NOS(1))==1.D0) THEN - IF (L(NOS(1))==1 .AND. SUM(NOS(2))==1.D0) THEN - ISUMP = SUM(NOS(1)) - NP = NOS(1) - NL = NOS(2) - ELSE - ISUMP = SUM(NOS(2)) - NP = NOS(2) - NL = NOS(1) - ENDIF - SP = ICHAR(SL(1:1)) - ICHAR('0') - LP = LVAL(SL(2:2)) - PS1 = SP + 1 - PS2 = SP - 1 - IF (ISUMP == 1) THEN - IPTR1 = 1 - ELSE - IPTR1 = SUMTAB(ISUMP-1) + 1 - ENDIF - IPTR2 = SUMTAB(ISUMP) - NOMACH = 0 - CALL LOOKUP (PARTAB, IPTR1, IPTR2, IND, NOMACH, PS1) - CALL LOOKUP (PARTAB, IPTR1, IPTR2, IND, NOMACH, PS2) - PSL(1:1) = CHAR(PARTAB(IND)+ICHAR('0')) - PSL(2:2) = PARCH(IND) - IF (NOMACH > 1) THEN - WRITE (0, *) ' AMBIGUOUS PARENT CASE' - 10 CONTINUE - WRITE (0, *) ' ENTER THE SL TERM FOR p(n) SUBSHELL' - READ (5, '(A)') PSL + SUM(NOS(1))==1.D0) THEN + IF (L(NOS(1))==1 .AND. SUM(NOS(2))==1.D0) THEN + ISUMP = SUM(NOS(1)) + NP = NOS(1) + NL = NOS(2) + ELSE + ISUMP = SUM(NOS(2)) + NP = NOS(2) + NL = NOS(1) + ENDIF + SP = ICHAR(SL(1:1)) - ICHAR('0') + LP = LVAL(SL(2:2)) + PS1 = SP + 1 + PS2 = SP - 1 + IF (ISUMP == 1) THEN + IPTR1 = 1 + ELSE + IPTR1 = SUMTAB(ISUMP-1) + 1 + ENDIF + IPTR2 = SUMTAB(ISUMP) + NOMACH = 0 + CALL LOOKUP (PARTAB, IPTR1, IPTR2, IND, NOMACH, PS1) + CALL LOOKUP (PARTAB, IPTR1, IPTR2, IND, NOMACH, PS2) + PSL(1:1) = CHAR(PARTAB(IND)+ICHAR('0')) + PSL(2:2) = PARCH(IND) + IF (NOMACH > 1) THEN + WRITE (0, *) ' AMBIGUOUS PARENT CASE' + 10 CONTINUE + WRITE (0, *) ' ENTER THE SL TERM FOR p(n) SUBSHELL' + READ (5, '(A)') PSL IF (PSL(2:2)>'a' .AND. PSL(2:2)<'z') PSL(2:2) = CHAR(ICHAR(& - PSL(2:2))+ICHAR('A')-ICHAR('a')) - PS1 = ICHAR(PSL(1:1)) - ICHAR('0') - PS2 = LVAL(PSL(2:2)) - CALL LOOKUP (PLVAL, IPTR1, IPTR2, IND, NOMACH, PS2) - IF (NOMACH/=1 .AND. PARTAB(IND)/=PS1) GO TO 10 - ENDIF - IF (ISUMP == 1) THEN - IPTR1 = 1 - ELSE - IPTR1 = PTRTAB(IND-1) + 1 - ENDIF - IPTR2 = PTRTAB(IND) - LV = L(NL) - PACVAL = SP*10 + LP - LV + 5 - NOMACH = 0 - CALL LOOKUP (LTAB, IPTR1, IPTR2, IND, NOMACH, PACVAL) - IF (NOMACH /= 1) THEN - DONE = .FALSE. - RETURN - ENDIF + PSL(2:2))+ICHAR('A')-ICHAR('a')) + PS1 = ICHAR(PSL(1:1)) - ICHAR('0') + PS2 = LVAL(PSL(2:2)) + CALL LOOKUP (PLVAL, IPTR1, IPTR2, IND, NOMACH, PS2) + IF (NOMACH/=1 .AND. PARTAB(IND)/=PS1) GO TO 10 + ENDIF + IF (ISUMP == 1) THEN + IPTR1 = 1 + ELSE + IPTR1 = PTRTAB(IND-1) + 1 + ENDIF + IPTR2 = PTRTAB(IND) + LV = L(NL) + PACVAL = SP*10 + LP - LV + 5 + NOMACH = 0 + CALL LOOKUP (LTAB, IPTR1, IPTR2, IND, NOMACH, PACVAL) + IF (NOMACH /= 1) THEN + DONE = .FALSE. + RETURN + ENDIF VAL1 = ((FINT(1,IND)*LV+FINT(2,IND))*LV+FINT(3,IND))/(5.D0*(2*LV& - - 1)*(2*LV + 3)) + - 1)*(2*LV + 3)) VAL2 = ((GINT1(1,IND)*LV+GINT1(2,IND))*LV+GINT1(3,IND))/(2.D0*(2& - *LV + 1)*(2*LV - 1)**2) + *LV + 1)*(2*LV - 1)**2) VAL3 = ((GINT2(1,IND)*LV+GINT2(2,IND))*LV+GINT2(3,IND))/(2.D0*(2& - *LV + 1)*(2*LV + 3)**2) + *LV + 1)*(2*LV + 3)**2) ! ! ... Add contributions from between p-subshell and l-electron ! - CALL ADD (VAL1, 2, NP, NL, .TRUE.) - CALL ADD (VAL1, 2, NL, NP, .TRUE.) - CALL ADD (VAL2, LV - 1, NP, NL, .FALSE.) - CALL ADD (VAL2, LV - 1, NL, NP, .FALSE.) - CALL ADD (VAL3, LV + 1, NP, NL, .FALSE.) - CALL ADD (VAL3, LV + 1, NL, NP, .FALSE.) + CALL ADD (VAL1, 2, NP, NL, .TRUE.) + CALL ADD (VAL1, 2, NL, NP, .TRUE.) + CALL ADD (VAL2, LV - 1, NP, NL, .FALSE.) + CALL ADD (VAL2, LV - 1, NL, NP, .FALSE.) + CALL ADD (VAL3, LV + 1, NP, NL, .FALSE.) + CALL ADD (VAL3, LV + 1, NL, NP, .FALSE.) ! ! ... Add deviations for p-subshell ! - CALL LOOKTM (1, PSL, ' ', SUM(NP), IP, NSL) - CALL DEV (NP, 1, SUM(NP), IP, DONE) - ELSE - DONE = .FALSE. - ENDIF - ENDIF - ELSE - DONE = .TRUE. - ENDIF - RETURN - END SUBROUTINE ENEXPR + CALL LOOKTM (1, PSL, ' ', SUM(NP), IP, NSL) + CALL DEV (NP, 1, SUM(NP), IP, DONE) + ELSE + DONE = .FALSE. + ENDIF + ENDIF + ELSE + DONE = .TRUE. + ENDIF + RETURN + END SUBROUTINE ENEXPR ! ! ------------------------------------------------------------------ ! E P T R @@ -2539,56 +2539,56 @@ END SUBROUTINE ENEXPR ! ! Determines the position of the electron in the electron list ! - SUBROUTINE EPTR(EL, ELSYMB, IEL, J2) + SUBROUTINE EPTR(EL, ELSYMB, IEL, J2) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(OUT) :: IEL - CHARACTER , INTENT(IN) :: ELSYMB*3 - CHARACTER , INTENT(IN) :: EL(*)*3 + INTEGER , INTENT(OUT) :: IEL + CHARACTER , INTENT(IN) :: ELSYMB*3 + CHARACTER , INTENT(IN) :: EL(*)*3 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J2, I, J1 + INTEGER :: J2, I, J1 CHARACTER(LEN=3) :: BL = ' ' !----------------------------------------------- - J2 = 0 + J2 = 0 ! ! ***** SEARCH ELECTRON LIST FOR LSYMB ! - IF (ELSYMB == BL) THEN - IEL = 0 - RETURN - ENDIF - DO I = 1, NWF - IF (EL(I) /= ELSYMB) CYCLE - IEL = I - RETURN - END DO - IEL = -1 - WRITE (0, 20) ELSYMB - 20 FORMAT(/,10X,A3,' NOT FOUND IN ELECTRON LIST') - J2 = 1 - RETURN - END SUBROUTINE EPTR + IF (ELSYMB == BL) THEN + IEL = 0 + RETURN + ENDIF + DO I = 1, NWF + IF (EL(I) /= ELSYMB) CYCLE + IEL = I + RETURN + END DO + IEL = -1 + WRITE (0, 20) ELSYMB + 20 FORMAT(/,10X,A3,' NOT FOUND IN ELECTRON LIST') + J2 = 1 + RETURN + END SUBROUTINE EPTR ! ! ----------------------------------------------------------------- ! F A C T R L ! ----------------------------------------------------------------- ! ! - SUBROUTINE FACTRL(NFACT) + SUBROUTINE FACTRL(NFACT) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE FACT_C + USE vast_kind_param, ONLY: DOUBLE + USE FACT_C ! ! GAM(I) = LOG( GAMMA(I-1) ), WHERE GAMMA(I) = FACTORIAL I-1 ! @@ -2596,26 +2596,26 @@ SUBROUTINE FACTRL(NFACT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NFACT + INTEGER , INTENT(IN) :: NFACT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: ZERO = 0.D0, ONE = 1.D0 , TWO = 2.d0 , GAMMA, X + INTEGER :: I + REAL(DOUBLE) :: ZERO = 0.D0, ONE = 1.D0 , TWO = 2.d0 , GAMMA, X !----------------------------------------------- ! - GAMMA = ONE - GAM(1) = ZERO - DO I = 1, NFACT - 1 - GAMMA = I*GAMMA - GAM(I+1) = DLOG(GAMMA) - END DO - DO I = NFACT + 1, 100 - X = I - 1 - GAM(I) = GAM(I-1) + DLOG(X) - END DO - RETURN - END SUBROUTINE FACTRL + GAMMA = ONE + GAM(1) = ZERO + DO I = 1, NFACT - 1 + GAMMA = I*GAMMA + GAM(I+1) = DLOG(GAMMA) + END DO + DO I = NFACT + 1, 100 + X = I - 1 + GAM(I) = GAM(I-1) + DLOG(X) + END DO + RETURN + END SUBROUTINE FACTRL ! ! ------------------------------------------------------------------ ! F K @@ -2624,29 +2624,29 @@ END SUBROUTINE FACTRL ! Returns the value of F (i,j) ! ! - REAL(KIND(0.0D0)) FUNCTION FK (I, J, K, REL) + REAL(KIND(0.0D0)) FUNCTION FK (I, J, K, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ykf_I - USE quads_I + USE ykf_I + USE quads_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J, K - LOGICAL :: REL + INTEGER :: I, J, K + LOGICAL :: REL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - CALL YKF (I, I, K, REL) - FK = QUADS(J,J,1) - RETURN - END FUNCTION FK + CALL YKF (I, I, K, REL) + FK = QUADS(J,J,1) + RETURN + END FUNCTION FK ! ! ------------------------------------------------------------------ ! G K @@ -2655,30 +2655,30 @@ END FUNCTION FK ! Returns the value of G (i,j). ! ! - REAL(KIND(0.0D0)) FUNCTION GK (I, J, K, REL) + REAL(KIND(0.0D0)) FUNCTION GK (I, J, K, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ykf_I - USE quads_I + USE ykf_I + USE quads_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J, K - LOGICAL :: REL + INTEGER :: I, J, K + LOGICAL :: REL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- !----------------------------------------------- - CALL YKF (I, J, K, REL) - GK = QUADS(I,J,1) - RETURN - END FUNCTION GK + CALL YKF (I, J, K, REL) + GK = QUADS(I,J,1) + RETURN + END FUNCTION GK ! ! ------------------------------------------------------------------ ! G R A N G E @@ -2689,95 +2689,95 @@ END FUNCTION GK ! orthogonality requirement. Eq. (7-10) is used to calculate the ! parameter. ! - SUBROUTINE GRANGE + SUBROUTINE GRANGE !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: E, SUM - USE LABEL_C, ONLY: EL - USE COEFF_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: E, SUM + USE LABEL_C, ONLY: EL + USE COEFF_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rotate_I - USE hl_I - USE ekin_I - USE a_I - USE b_I - USE rk_I + USE rotate_I + USE hl_I + USE ekin_I + USE a_I + USE b_I + USE rk_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, II, K, KK - REAL(DOUBLE) :: C, RES + INTEGER :: I, J, II, K, KK + REAL(DOUBLE) :: C, RES !----------------------------------------------- ! ! ***** ROTATE PAIRS CONNECTED BY ORTHOGONALITY BUT NOT WHEN ONE OF ! THE ORBITALS IS SIMULTANEOUSLY ORTHOGONAL TO A NON-ORTHOGONAL ! PAIR ! - DO I = IB, NWF - 1 - DO J = I + 1, NWF - IF (DABS(E(I,J)) <= 1.D-10) CYCLE - CALL ROTATE (I, J) - END DO - END DO + DO I = IB, NWF - 1 + DO J = I + 1, NWF + IF (DABS(E(I,J)) <= 1.D-10) CYCLE + CALL ROTATE (I, J) + END DO + END DO ! ! ***** COMPUTE OFF-DIAGONAL ENERGY PARAMETERS ! - DO I = MAX0(2,IB), NWF - DO J = 1, I - 1 - IF (DABS(E(I,J)) > 1.D-10) THEN - IF (J < IB) THEN - E(I,J) = HL(EL,I,J,REL) - EKIN(I,J,REL) - E(J,I) = D0 - ELSE IF (SUM(I) == SUM(J)) THEN - C = HL(EL,I,J,REL) - (EKIN(I,J,REL) + EKIN(J,I,REL))/D2 - E(I,J) = C - E(J,I) = C - ELSE - RES = D0 - DO II = 1, NWF - IF (II==I .OR. II==J) THEN - DO K = 0, 2*L(I), 2 - IF (II == I) THEN - C = A(I,I,K) - A(J,I,K) - B(J,I,K) + DO I = MAX0(2,IB), NWF + DO J = 1, I - 1 + IF (DABS(E(I,J)) > 1.D-10) THEN + IF (J < IB) THEN + E(I,J) = HL(EL,I,J,REL) - EKIN(I,J,REL) + E(J,I) = D0 + ELSE IF (SUM(I) == SUM(J)) THEN + C = HL(EL,I,J,REL) - (EKIN(I,J,REL) + EKIN(J,I,REL))/D2 + E(I,J) = C + E(J,I) = C + ELSE + RES = D0 + DO II = 1, NWF + IF (II==I .OR. II==J) THEN + DO K = 0, 2*L(I), 2 + IF (II == I) THEN + C = A(I,I,K) - A(J,I,K) - B(J,I,K) IF (DABS(C) > 1.D-10) RES = RES + C*RK(I,I,I,J,K,& - REL) - ELSE IF (II == J) THEN - C = A(J,J,K) - A(I,J,K) - B(I,J,K) + REL) + ELSE IF (II == J) THEN + C = A(J,J,K) - A(I,J,K) - B(I,J,K) IF (DABS(C) > 1.D-10) RES = RES - C*RK(J,J,J,I,K,& - REL) - ENDIF - END DO - ELSE - DO K = 0, 2*MIN0(L(I),L(II)), 2 - C = A(I,II,K) - A(J,II,K) + REL) + ENDIF + END DO + ELSE + DO K = 0, 2*MIN0(L(I),L(II)), 2 + C = A(I,II,K) - A(J,II,K) IF (DABS(C) > 1.D-10) RES = RES + C*RK(I,II,J,II,K,& - REL) - KK = ABS(L(I)-L(II)) + K - C = B(I,II,KK) - B(J,II,KK) - IF (DABS(C) <= 1.D-10) CYCLE - RES = RES + C*RK(I,II,II,J,KK,REL) - END DO - ENDIF - END DO - E(I,J) = D2*SUM(J)*RES/(SUM(I)-SUM(J)) - E(J,I) = SUM(I)*E(I,J)/SUM(J) - ENDIF - ENDIF - IF (DABS(E(I,J)) <= 1.D-10) CYCLE - WRITE (6, 35) EL(I), EL(J), E(I,J), EL(J), EL(I), E(J,I) - 35 FORMAT(7X,2(3X,'E(',2A3,') =',F12.5)) - END DO - END DO - RETURN - END SUBROUTINE GRANGE + REL) + KK = ABS(L(I)-L(II)) + K + C = B(I,II,KK) - B(J,II,KK) + IF (DABS(C) <= 1.D-10) CYCLE + RES = RES + C*RK(I,II,II,J,KK,REL) + END DO + ENDIF + END DO + E(I,J) = D2*SUM(J)*RES/(SUM(I)-SUM(J)) + E(J,I) = SUM(I)*E(I,J)/SUM(J) + ENDIF + ENDIF + IF (DABS(E(I,J)) <= 1.D-10) CYCLE + WRITE (6, 35) EL(I), EL(J), E(I,J), EL(J), EL(I), E(J,I) + 35 FORMAT(7X,2(3X,'E(',2A3,') =',F12.5)) + END DO + END DO + RETURN + END SUBROUTINE GRANGE ! ! ------------------------------------------------------------------ ! H E L P @@ -2785,28 +2785,28 @@ END SUBROUTINE GRANGE ! ! Provide HELP information about the data requested ! - SUBROUTINE HELP(CASE) + SUBROUTINE HELP(CASE) IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: CASE + INTEGER , INTENT(IN) :: CASE !----------------------------------------------- ! - SELECT CASE (CASE) + SELECT CASE (CASE) ! - CASE DEFAULT - WRITE (0, 11) + CASE DEFAULT + WRITE (0, 11) ! ***** Which orbitals varied? 11 FORMAT(/,/,1X,'Response ALL will vary all orbitals'/,11X,& 'NONE will not vary any orbitals'/,11X,& '=n (integer n), will vary last n'/,11X,& 'with comma delimited list will vary',1X,& - 'only the orbitals in the list'/,/) - RETURN - - CASE (2) - WRITE (0, 21) + 'only the orbitals in the list'/,/) + RETURN + + CASE (2) + WRITE (0, 21) ! ***** Default electron parameters ? 21 FORMAT(/,/,1X,'Response N will prompt the user for:'/,/,7X,& 'S : Screening parameter (Real number) '/,7X,& @@ -2823,11 +2823,11 @@ SUBROUTINE HELP(CASE) 'program will automatically select Method 2.'/,15X,& '3 - Method 3 is similar to Method 1 but omits all checks'/,20X,& 'for acceptability.'/,7X,'ACC : Inital accelerating factor '/,18X& - ,'( Real number such that 0 .LE. ACC .LT. 1 )'/,/) - RETURN - - CASE (3) - WRITE (0, 31) + ,'( Real number such that 0 .LE. ACC .LT. 1 )'/,/) + RETURN + + CASE (3) + WRITE (0, 31) ! ***** Default values (NO,STRONG) ? 31 FORMAT(/,/,1X,'Response Y will set default values as follows'/,/,10X,& 'NO - Maximum number of points in the range of the '/,15X,& @@ -2837,20 +2837,20 @@ SUBROUTINE HELP(CASE) 'NO - Maximum number of points in the range of '/,15X,& 'the function which should be a positive integer'/,15X,& 'from 160 for a small atom to 220 for a large atom.'/,10X,& - 'Strong - may be set to .TRUE. or .FALSE by user.'/,/) - RETURN - - CASE (4) - WRITE (0, 41) + 'Strong - may be set to .TRUE. or .FALSE by user.'/,/) + RETURN + + CASE (4) + WRITE (0, 41) ! ***** Default values for remaining parameters ? 41 FORMAT(/,/,1X,1X,'Response Y --Sets the following default values'/,/,& 10X,'PRINT=.FALSE.'/,10X,'SCFTOL=1.D-8'/,10X,'NSCF=12'/,10X,& 'IC=2 + (NWF + 1 - IB)/4'/,10X,'TRACE=.FALSE.'/,/,1X,& - 'Response N --prompts user for new parameter values.'/,/) - RETURN - - CASE (5) - WRITE (0, 51) + 'Response N --prompts user for new parameter values.'/,/) + RETURN + + CASE (5) + WRITE (0, 51) ! ***** Default values for PRINT, SCFTOL ? 51 FORMAT(/,/,1X,1X,& 'Response Y --Default value for PRINT is .FALSE. thus'/,16X,& @@ -2859,21 +2859,21 @@ SUBROUTINE HELP(CASE) 'self-consistency tolerance for radial functions is set'/,16X,& 'to a default value of 1.D-8 .'/,/,1X,& 'Response N --prompts user for new values of PRINT and ',& - 'SCFTOL .'/,/) - RETURN - - CASE (6) - WRITE (0, 61) + 'SCFTOL .'/,/) + RETURN + + CASE (6) + WRITE (0, 61) ! ***** Default values for NSCF, IC ? 61 FORMAT(/,/,1X,1X,& 'Response Y --NSCF, the maximum number of cycles for'/,16X,& 'the SCF process is set to default value of 12 and'/,& 'IC is set to 2 + (NWF + 1 -IB)/4 .'/,/,1X,& - 'Response N --user prompted for new NSCF and IC values'/,/) - RETURN - - CASE (7) - WRITE (0, 71) + 'Response N --user prompted for new NSCF and IC values'/,/) + RETURN + + CASE (7) + WRITE (0, 71) ! ***** Default values for TRACE ? 71 FORMAT(/,/,1X,& 'Response Y --sets trace to default value of .FALSE. thus a'/,16X,& @@ -2882,39 +2882,39 @@ SUBROUTINE HELP(CASE) 'If .TRUE. a trace will be printed showing the energy ',& 'adjustment'/,16X,'process used by METHD1 for finding an',& ' acceptable solution'/,16X,'with the correct number of',' nodes.'/& - ,/) - RETURN - - CASE (8) - WRITE (0, 81) + ,/) + RETURN + + CASE (8) + WRITE (0, 81) ! ***** Additional parameters ? 81 FORMAT(/,/,1X,'Response Y --additional values may be computed for '/,& 16X,'SLATER OR MAGNETIC INTEGRALS'/,16X,& 'EXPECTATION VALUES OF R**K'/,/,16X,& 'ELECTRON DENSITY AT THE NUCLEUS'/,16X,'SPIN-ORBIT ','PARAMETER'/,& 16X,'TRANSITION INTEGRALS'/,/,1X,& - 'Response N --additional parameter computation is ','skipped'/,/) - RETURN - - CASE (9) - WRITE (0, 91) + 'Response N --additional parameter computation is ','skipped'/,/) + RETURN + + CASE (9) + WRITE (0, 91) ! ***** Do you wish to continue along the sequence ? 91 FORMAT(/,/,1X,'Response Y --sequence is continued'/,/,1X,& 'Response N --current case is ended, but new case may be'/,16X,& - 'started'/,/) - RETURN - - CASE (10) - WRITE (0, 101) + 'started'/,/) + RETURN + + CASE (10) + WRITE (0, 101) ! ***** Do you wish to continue ? 101 FORMAT(/,/,1X,& 'Response Y --prompts user for additional iterations and'/,16X,& 'new IC. Then performs additional NSCF self-consistent'/,16X,& 'field iterations.'/,/,1X,& - 'Response N --terminates the calculation.'/,/) - RETURN - END SELECT - END SUBROUTINE HELP + 'Response N --terminates the calculation.'/,/) + RETURN + END SELECT + END SUBROUTINE HELP ! ! ------------------------------------------------------------------ ! H L @@ -2923,84 +2923,84 @@ END SUBROUTINE HELP ! Returns the value of , using a special formula to ! preserve symmetry. ! - REAL(KIND(0.0D0)) FUNCTION HL (EL, I, J, REL) + REAL(KIND(0.0D0)) FUNCTION HL (EL, I, J, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rlshft_I + USE rlshft_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - LOGICAL , INTENT(IN) :: REL - CHARACTER , INTENT(IN) :: EL(*)*3 + INTEGER :: I + INTEGER :: J + LOGICAL , INTENT(IN) :: REL + CHARACTER , INTENT(IN) :: EL(*)*3 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LI, MM, K + INTEGER :: LI, MM, K REAL(DOUBLE) :: C, A1, A2, A3, ZR, DI1, DI2, DJ1, DJ2, DI4, DI3, DI5, DI6& - , DJ4, DJ3, DJ5, DJ6, TZ, HL2 + , DJ4, DJ3, DJ5, DJ6, TZ, HL2 !----------------------------------------------- - IF (IABS(L(I)-L(J)) /= 0) THEN - WRITE (0, 4) EL(I), L(I), EL(J), L(J) + IF (IABS(L(I)-L(J)) /= 0) THEN + WRITE (0, 4) EL(I), L(I), EL(J), L(J) 4 FORMAT(10X,'UNALLOWED L VALUES OCCURRED IN HL SUBROUTINE'/,2(10X,A3,& - ' HAS L = ',I3)) - STOP - ENDIF - LI = L(I) - C = 2*LI + 1 - A1 = -D2/(C*(LI + 1)) - A2 = A1/((C + D2)*(LI + 1)) - A3 = A2/((LI + 2)*(LI + 1)) - ZR = Z*R(1) - HL = H*C*P(1,I)*P(1,J)*(D1 + ZR*(A1 + ZR*(A2 + ZR*A3))) - MM = MIN0(MAX(I)+3,MAX(J)+3,ND-1) - K = 2 - C = D4/D3 - DI1 = P(K+1,I) - P(K-1,I) - DI2 = P(K+1,I) - D2*P(K,I) + P(K-1,I) - DJ1 = P(K+1,J) - P(K-1,J) - DJ2 = P(K+1,J) - D2*P(K,J) + P(K-1,J) - HL = HL + DI1*DJ1 + C*DI2*DJ2 - DO K = 4, MM, 2 - DI1 = P(K+1,I) - P(K-1,I) - DI2 = P(K+1,I) - D2*P(K,I) + P(K-1,I) - DI4 = P(K+2,I) - D4*(P(K+1,I)+P(K-1,I)) + D6*P(K,I) + P(K-2,I) - DI3 = P(K+2,I) - P(K-2,I) - D2*DI1 + ' HAS L = ',I3)) + STOP + ENDIF + LI = L(I) + C = 2*LI + 1 + A1 = -D2/(C*(LI + 1)) + A2 = A1/((C + D2)*(LI + 1)) + A3 = A2/((LI + 2)*(LI + 1)) + ZR = Z*R(1) + HL = H*C*P(1,I)*P(1,J)*(D1 + ZR*(A1 + ZR*(A2 + ZR*A3))) + MM = MIN0(MAX(I)+3,MAX(J)+3,ND-1) + K = 2 + C = D4/D3 + DI1 = P(K+1,I) - P(K-1,I) + DI2 = P(K+1,I) - D2*P(K,I) + P(K-1,I) + DJ1 = P(K+1,J) - P(K-1,J) + DJ2 = P(K+1,J) - D2*P(K,J) + P(K-1,J) + HL = HL + DI1*DJ1 + C*DI2*DJ2 + DO K = 4, MM, 2 + DI1 = P(K+1,I) - P(K-1,I) + DI2 = P(K+1,I) - D2*P(K,I) + P(K-1,I) + DI4 = P(K+2,I) - D4*(P(K+1,I)+P(K-1,I)) + D6*P(K,I) + P(K-2,I) + DI3 = P(K+2,I) - P(K-2,I) - D2*DI1 DI5 = P(K+3,I) - P(K-3,I) - D4*(P(K+2,I)-P(K-2,I)) + 5.D0*(P(K+1,I)-P(& - K-1,I)) + K-1,I)) DI6 = P(K+3,I) + P(K-3,I) - D6*(P(K+2,I)+P(K-2,I)) + 15.D0*(P(K+1,I)+P& - (K-1,I)) - 20.D0*P(K,I) - DJ1 = P(K+1,J) - P(K-1,J) - DJ2 = P(K+1,J) - D2*P(K,J) + P(K-1,J) - DJ4 = P(K+2,J) - D4*(P(K+1,J)+P(K-1,J)) + D6*P(K,J) + P(K-2,J) - DJ3 = P(K+2,J) - P(K-2,J) - D2*DJ1 + (K-1,I)) - 20.D0*P(K,I) + DJ1 = P(K+1,J) - P(K-1,J) + DJ2 = P(K+1,J) - D2*P(K,J) + P(K-1,J) + DJ4 = P(K+2,J) - D4*(P(K+1,J)+P(K-1,J)) + D6*P(K,J) + P(K-2,J) + DJ3 = P(K+2,J) - P(K-2,J) - D2*DJ1 DJ5 = P(K+3,J) - P(K-3,J) - D4*(P(K+2,J)-P(K-2,J)) + 5.D0*(P(K+1,J)-P(& - K-1,J)) + K-1,J)) DJ6 = P(K+3,J) + P(K-3,J) - D6*(P(K+2,J)+P(K-2,J)) + 15.D0*(P(K+1,J)+P& - (K-1,J)) - 20.D0*P(K,J) + (K-1,J)) - 20.D0*P(K,J) HL = HL + DI1*DJ1 + C*DI2*DJ2 + (DI3*DJ3 + DI2*DJ4 + DI4*DJ2)/45.D0 - & (DI3*DJ5 + DI5*DJ3)/252.D0 - (DI2*DJ6 + DI6*DJ2 - 1.1*DI4*DJ4)/& - 378.D0 - END DO - TZ = Z + Z - C = (LI + D5)**2 - HL2 = D5*(TZ*R(1)-C)*P(1,I)*P(1,J) + 378.D0 + END DO + TZ = Z + Z + C = (LI + D5)**2 + HL2 = D5*(TZ*R(1)-C)*P(1,I)*P(1,J) HL2 = HL2 + SUM(D2*(TZ*R(2:MM:2)-C)*P(2:MM:2,I)*P(2:MM:2,J)+(TZ*R(3:MM+1:& - 2)-C)*P(3:MM+1:2,I)*P(3:MM+1:2,J)) - HL = (-HL/(D2*H)) + HL2*H1 - IF (REL) HL = HL - D2*RLSHFT(I,J) - - RETURN - END FUNCTION HL + 2)-C)*P(3:MM+1:2,I)*P(3:MM+1:2,J)) + HL = (-HL/(D2*H)) + HL2*H1 + IF (REL) HL = HL - D2*RLSHFT(I,J) + + RETURN + END FUNCTION HL ! ! ------------------------------------------------------------------ ! H N O R M @@ -3010,42 +3010,42 @@ END FUNCTION HL ! hydrogenic function with nuclear charge ZZ. ! ! - REAL(KIND(0.0D0)) FUNCTION HNORM (N, L, ZZ) + REAL(KIND(0.0D0)) FUNCTION HNORM (N, L, ZZ) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(IN) :: L - REAL(DOUBLE) , INTENT(IN) :: ZZ + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(IN) :: L + REAL(DOUBLE) , INTENT(IN) :: ZZ !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: M, I - REAL(DOUBLE) :: A, B, T, D -!----------------------------------------------- - M = L + L + 1 - A = N + L - B = M - T = A - D = B - M = M - 1 - IF (M /= 0) THEN - DO I = 1, M - A = A - D1 - B = B - D1 - T = T*A - D = D*B - END DO - ENDIF - HNORM = DSQRT(ZZ*T)/(N*D) - RETURN - END FUNCTION HNORM + INTEGER :: M, I + REAL(DOUBLE) :: A, B, T, D +!----------------------------------------------- + M = L + L + 1 + A = N + L + B = M + T = A + D = B + M = M - 1 + IF (M /= 0) THEN + DO I = 1, M + A = A - D1 + B = B - D1 + T = T*A + D = D*B + END DO + ENDIF + HNORM = DSQRT(ZZ*T)/(N*D) + RETURN + END FUNCTION HNORM ! MCHF_HF (Part2 of 2) ! ------------------------------------------------------------------ ! H W F @@ -3055,56 +3055,56 @@ END FUNCTION HNORM ! with nuclear charge ZZ and radius r. ! ! - REAL(KIND(0.0D0)) FUNCTION HWF (N, L, ZZ, R) + REAL(KIND(0.0D0)) FUNCTION HWF (N, L, ZZ, R) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(IN) :: L - REAL(DOUBLE) , INTENT(IN) :: ZZ - REAL(DOUBLE) , INTENT(IN) :: R + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(IN) :: L + REAL(DOUBLE) , INTENT(IN) :: ZZ + REAL(DOUBLE) , INTENT(IN) :: R !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, I - REAL(DOUBLE) :: P, A, B, C, X + INTEGER :: K, I + REAL(DOUBLE) :: P, A, B, C, X !----------------------------------------------- - K = N - L - 1 - P = D1 - A = D1 - B = K - C = N + L - X = -D2*ZZ*R/N + K = N - L - 1 + P = D1 + A = D1 + B = K + C = N + L + X = -D2*ZZ*R/N ! ! ***** TEST IF UNDERFLOW MAY OCCUR, IF SO SET HWF = 0 ! - IF (X >= (-150.D0)) THEN - IF (K >= 0) THEN - IF (K /= 0) THEN - DO I = 1, K - P = D1 + A/B*P/C*X - A = A + D1 - B = B - D1 - C = C - D1 - END DO - ENDIF - HWF = P*DEXP(X/D2)*(-X)**(L + 1) - RETURN - ENDIF - WRITE (0, 7) N, L, ZZ, R + IF (X >= (-150.D0)) THEN + IF (K >= 0) THEN + IF (K /= 0) THEN + DO I = 1, K + P = D1 + A/B*P/C*X + A = A + D1 + B = B - D1 + C = C - D1 + END DO + ENDIF + HWF = P*DEXP(X/D2)*(-X)**(L + 1) + RETURN + ENDIF + WRITE (0, 7) N, L, ZZ, R 7 FORMAT(' FORBIDDEN COMBINATION OF N AND L IN HWF SUBPROGRAM'/,' N =',& - I4,' L =',I4,' Z =',F6.1,' R =',F8.4) - STOP - ENDIF - HWF = D0 - RETURN - END FUNCTION HWF + I4,' L =',I4,' Z =',F6.1,' R =',F8.4) + STOP + ENDIF + HWF = D0 + RETURN + END FUNCTION HWF ! ! ------------------------------------------------------------------ ! I N I T @@ -3114,18 +3114,18 @@ END FUNCTION HWF ! which define the average energy of a configuration. ! ! - SUBROUTINE INIT + SUBROUTINE INIT !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE EAV_C - USE FACT_C - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE EAV_C + USE FACT_C + USE PARAM_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE factrl_I + USE factrl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -3133,117 +3133,117 @@ SUBROUTINE INIT ! ! ***** SET THE COMMONLY USED DOUBLE PRECISION CONSTANTS ! - D0 = 0.D0 - D1 = 1.D0 - D2 = 2.D0 - D3 = 3.D0 - D4 = 4.D0 - D5 = 1.D0/2.D0 - D6 = 6.D0 - D8 = 8.D0 - D10 = 10.D0 - D12 = 12.D0 - D16 = 16.D0 - D30 = 30.D0 + D0 = 0.D0 + D1 = 1.D0 + D2 = 2.D0 + D3 = 3.D0 + D4 = 4.D0 + D5 = 1.D0/2.D0 + D6 = 6.D0 + D8 = 8.D0 + D10 = 10.D0 + D12 = 12.D0 + D16 = 16.D0 + D30 = 30.D0 ! ! ***** Set the factorial needed by RME ! - CALL FACTRL (32) + CALL FACTRL (32) ! ! ***** SET FINE STRUCTURE CONSTANT ! - FINE = 0.25D0/137.036**2 + FINE = 0.25D0/137.036**2 ! ! ***** SET THE STARTING POINT, STEP SIZE, AND RELATED PARAMETERS ! - RHO = -4.D0 - H = 1./16.D0 - H1 = H/1.5 - H3 = H/3. - CH = H*H/12. - EH = DEXP((-H)) - NO = 220 - ND = NO - 2 + RHO = -4.D0 + H = 1./16.D0 + H1 = H/1.5 + H3 = H/3. + CH = H*H/12. + EH = DEXP((-H)) + NO = 220 + ND = NO - 2 ! ! ***** AVERAGE INTERACTIONS FOR EQUIVALENT ELECTRONS ! ! ***** P - P ! - CCA(1) = 2.D0/25.D0 + CCA(1) = 2.D0/25.D0 ! ! ***** D - D ! - CCA(2) = 2.D0/63.D0 - CCA(3) = 2.D0/63.D0 + CCA(2) = 2.D0/63.D0 + CCA(3) = 2.D0/63.D0 ! ! ***** F - F ! - CCA(4) = 4.D0/195.D0 - CCA(5) = 2.D0/143.D0 - CCA(6) = 100.D0/5577.D0 + CCA(4) = 4.D0/195.D0 + CCA(5) = 2.D0/143.D0 + CCA(6) = 100.D0/5577.D0 ! ! ***** G - G ! - CCA(7) = 20.D0/1309.D0 - CCA(8) = 162.D0/17017.D0 - CCA(9) = 20.D0/2431.D0 - CCA(10) = 4410.D0/371943.D0 + CCA(7) = 20.D0/1309.D0 + CCA(8) = 162.D0/17017.D0 + CCA(9) = 20.D0/2431.D0 + CCA(10) = 4410.D0/371943.D0 ! ! ! ***** AVERAGE INTERACTIONS FOR NON-EQUIVALENT ELECTRONS ! ! ***** S - ( S, P, D, F, G ) ! - CCB(1) = 1.D0/2.D0 - CCB(2) = 1.D0/6.D0 - CCB(3) = 1.D0/10.D0 - CCB(4) = 1.D0/14.D0 - CCB(5) = 1.D0/18.D0 + CCB(1) = 1.D0/2.D0 + CCB(2) = 1.D0/6.D0 + CCB(3) = 1.D0/10.D0 + CCB(4) = 1.D0/14.D0 + CCB(5) = 1.D0/18.D0 ! ! ***** P - ( P, D, F, G ) ! - CCB(6) = 1.D0/6.D0 - CCB(7) = 1.D0/15.D0 - CCB(8) = 1.D0/15.D0 - CCB(9) = 3.D0/70.D0 - CCB(10) = 3.D0/70.D0 - CCB(11) = 2.D0/63.D0 - CCB(12) = 2.D0/63.D0 - CCB(13) = 5.D0/198.D0 + CCB(6) = 1.D0/6.D0 + CCB(7) = 1.D0/15.D0 + CCB(8) = 1.D0/15.D0 + CCB(9) = 3.D0/70.D0 + CCB(10) = 3.D0/70.D0 + CCB(11) = 2.D0/63.D0 + CCB(12) = 2.D0/63.D0 + CCB(13) = 5.D0/198.D0 ! ! ***** D - ( D, F, G ) ! - CCB(14) = 1.D0/10.D0 - CCB(15) = 1.D0/35.D0 - CCB(16) = 1.D0/35.D0 - CCB(17) = 3.D0/70.D0 - CCB(18) = 2.D0/105.D0 - CCB(19) = 5.D0/231.D0 - CCB(20) = 1.D0/35.D0 - CCB(21) = 10.D0/693.D0 - CCB(22) = 5.D0/286.D0 + CCB(14) = 1.D0/10.D0 + CCB(15) = 1.D0/35.D0 + CCB(16) = 1.D0/35.D0 + CCB(17) = 3.D0/70.D0 + CCB(18) = 2.D0/105.D0 + CCB(19) = 5.D0/231.D0 + CCB(20) = 1.D0/35.D0 + CCB(21) = 10.D0/693.D0 + CCB(22) = 5.D0/286.D0 ! ! ***** F - ( F, G ) ! - CCB(23) = 1.D0/14.D0 - CCB(24) = 2.D0/105.D0 - CCB(25) = 1.D0/77.D0 - CCB(26) = 50.D0/3003.D0 - CCB(27) = 2.D0/63.D0 - CCB(28) = 1.D0/77.D0 - CCB(29) = 10.D0/1001.D0 - CCB(30) = 35.D0/2574.D0 + CCB(23) = 1.D0/14.D0 + CCB(24) = 2.D0/105.D0 + CCB(25) = 1.D0/77.D0 + CCB(26) = 50.D0/3003.D0 + CCB(27) = 2.D0/63.D0 + CCB(28) = 1.D0/77.D0 + CCB(29) = 10.D0/1001.D0 + CCB(30) = 35.D0/2574.D0 ! ! ***** G - ( G ) ! - CCB(31) = 1.D0/18.D0 - CCB(32) = 10.D0/693.D0 - CCB(33) = 9.D0/1001.D0 - CCB(34) = 10.D0/1287.D0 - CCB(35) = 245.D0/21879.D0 - RETURN - END SUBROUTINE INIT -! + CCB(31) = 1.D0/18.D0 + CCB(32) = 10.D0/693.D0 + CCB(33) = 9.D0/1001.D0 + CCB(34) = 10.D0/1287.D0 + CCB(35) = 245.D0/21879.D0 + RETURN + END SUBROUTINE INIT +! ! ------------------------------------------------------------------ ! L O O K - T M ! ------------------------------------------------------------------ @@ -3251,121 +3251,121 @@ END SUBROUTINE INIT ! Add the deviations to the average energy for a partially filled ! p- or d- shell ! - SUBROUTINE LOOKTM(L, SL, SEN, Q, IP, NSL) + SUBROUTINE LOOKTM(L, SL, SEN, Q, IP, NSL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: L - INTEGER , INTENT(OUT) :: IP - INTEGER , INTENT(OUT) :: NSL - REAL(DOUBLE) , INTENT(IN) :: Q - CHARACTER , INTENT(IN) :: SL*2 - CHARACTER , INTENT(IN) :: SEN + INTEGER , INTENT(IN) :: L + INTEGER , INTENT(OUT) :: IP + INTEGER , INTENT(OUT) :: NSL + REAL(DOUBLE) , INTENT(IN) :: Q + CHARACTER , INTENT(IN) :: SL*2 + CHARACTER , INTENT(IN) :: SEN !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I1, J2 + INTEGER :: I1, J2 INTEGER , DIMENSION(5) :: IPTR = (/ 6, 11, 19, 35, 51 /) - INTEGER :: N, IBEGIN, IEND, I + INTEGER :: N, IBEGIN, IEND, I CHARACTER(LEN=3), DIMENSION(51) :: TERMS = (/ & '3P2', '1D2', '1S0', '4S3', '2D3', '2P1', '3F2', '3P2', '1G2',& '1D2', '1S0', '4F3', '4P3', '2H3', '2G3', '2F3', '2D1', '2D3',& '2P3', '5D4', '3H4', '3G4', '3F2', '3F4', '3D4', '3P2', '3P4',& - '1I4', '1G2', '1G4', '1F4', '1D2', '1D4', '1S0', '1S4', '6S5',& + '1I4', '1G2', '1G4', '1F4', '1D2', '1D4', '1S0', '1S4', '6S5',& '4G5', '4F3', '4D5', '4P3', '2I5', '2H3', '2G3', '2G5', '2F3',& - '2F5', '2D1', '2D3', '2D5', '2P3', '2S5'/) - + '2F5', '2D1', '2D3', '2D5', '2P3', '2S5'/) + ! ! --- search for a partially unfilled p- or d-shell ! - N = Q - IF (N > 2*L + 1) N = 4*L + 2 - N - IP = 0 - NSL = 0 - IF (N>1 .AND. L<=2) THEN - IF (L == 1) THEN - IBEGIN = 1 - IEND = 6 - ELSE - IBEGIN = IPTR(N-1) + 1 - IEND = IPTR(N) - ENDIF - I = IBEGIN - I1 = I - J2 = MAX(IEND,I1) - DO I = I1, J2 - IF (SL /= TERMS(I)(1:2)) CYCLE - IF (SEN/=' ' .AND. SEN/=TERMS(I)(3:3)) CYCLE - NSL = NSL + 1 - IP = I - END DO - ELSE IF (N==1 .AND. SL(1:1)=='2') THEN - NSL = 1 - ENDIF - RETURN - END SUBROUTINE LOOKTM + N = Q + IF (N > 2*L + 1) N = 4*L + 2 - N + IP = 0 + NSL = 0 + IF (N>1 .AND. L<=2) THEN + IF (L == 1) THEN + IBEGIN = 1 + IEND = 6 + ELSE + IBEGIN = IPTR(N-1) + 1 + IEND = IPTR(N) + ENDIF + I = IBEGIN + I1 = I + J2 = MAX(IEND,I1) + DO I = I1, J2 + IF (SL /= TERMS(I)(1:2)) CYCLE + IF (SEN/=' ' .AND. SEN/=TERMS(I)(3:3)) CYCLE + NSL = NSL + 1 + IP = I + END DO + ELSE IF (N==1 .AND. SL(1:1)=='2') THEN + NSL = 1 + ENDIF + RETURN + END SUBROUTINE LOOKTM ! ! ----------------------------------------------------------------- ! L O O K - U P ! ----------------------------------------------------------------- ! - SUBROUTINE LOOKUP(TAB, P1, P2, IND, NO, KEY) + SUBROUTINE LOOKUP(TAB, P1, P2, IND, NO, KEY) IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: P1, P2 - INTEGER , INTENT(OUT) :: IND - INTEGER , INTENT(INOUT) :: NO - INTEGER , INTENT(IN) :: KEY - INTEGER , INTENT(IN) :: TAB(*) + INTEGER , INTENT(IN) :: P1, P2 + INTEGER , INTENT(OUT) :: IND + INTEGER , INTENT(INOUT) :: NO + INTEGER , INTENT(IN) :: KEY + INTEGER , INTENT(IN) :: TAB(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- - DO I = P1, P2 - IF (TAB(I) /= KEY) CYCLE - NO = NO + 1 - IND = I - END DO - RETURN - END SUBROUTINE LOOKUP + DO I = P1, P2 + IF (TAB(I) /= KEY) CYCLE + NO = NO + 1 + IND = I + END DO + RETURN + END SUBROUTINE LOOKUP ! ! ----------------------------------------------------------------- ! L V A L ! ----------------------------------------------------------------- ! ! - INTEGER FUNCTION LVAL (SYMBOL) + INTEGER FUNCTION LVAL (SYMBOL) IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: SYMBOL + CHARACTER , INTENT(IN) :: SYMBOL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LOCATE - CHARACTER(LEN=22) :: SET = 'spdfghiklmnSPDFGHIKLMN' + INTEGER :: LOCATE + CHARACTER(LEN=22) :: SET = 'spdfghiklmnSPDFGHIKLMN' - LOCATE = INDEX(SET,SYMBOL) - IF (LOCATE <= 11) THEN - LVAL = LOCATE - 1 - ELSE - LVAL = LOCATE - 12 - ENDIF + LOCATE = INDEX(SET,SYMBOL) + IF (LOCATE <= 11) THEN + LVAL = LOCATE - 1 + ELSE + LVAL = LOCATE - 12 + ENDIF IF (LVAL <0) then Write (0,*) 'Symbol ',SYMBOL,' was not found' STOP END IF - RETURN - END FUNCTION LVAL + RETURN + END FUNCTION LVAL ! ! ------------------------------------------------------------------ ! M E N U @@ -3376,172 +3376,172 @@ END FUNCTION LVAL ! requested by the user. ! ! - SUBROUTINE MENU + SUBROUTINE MENU !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE LABEL_C - USE RADIAL_C, ONLY: AZ, L, NOD - USE TEST_C + USE vast_kind_param, ONLY: DOUBLE + USE LABEL_C + USE RADIAL_C, ONLY: AZ, L, NOD + USE TEST_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE eptr_I - USE quadr_I - USE fk_I - USE gk_I - USE rk_I - USE sn_I - USE vk_I - USE bwzeta_I + USE eptr_I + USE quadr_I + USE fk_I + USE gk_I + USE rk_I + USE sn_I + USE vk_I + USE bwzeta_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J1, J2, J3, J4, J5, J6, J7, J8, J9, IFUNC, K, I, I1, I2, I3, & - I4, LL - REAL(DOUBLE) :: RKEV, SI, D, ZETA, ZETACM, TI - CHARACTER :: EL1*3, EL2*3, EL3*3, EL4*3, FUNC + I4, LL + REAL(DOUBLE) :: RKEV, SI, D, ZETA, ZETACM, TI + CHARACTER :: EL1*3, EL2*3, EL3*3, EL4*3, FUNC !----------------------------------------------- ! - - 4 CONTINUE - WRITE (0, 5) + + 4 CONTINUE + WRITE (0, 5) 5 FORMAT(/,/,5X,' These various functions are available:',/,/,10X,& '1 - EXPECTATION VALUES OF R**K'/,10X,& '2 - SLATER OR MAGNETIC INTEGRALS'/,10X,& '3 - ELECTRON DENSITY AT THE NUCLEUS'/,10X,'4 - SPIN-ORBIT PARAMETER'/& - ,10X,'5 - TRANSITION INTEGRALS'/,10X,'6 - EXIT TO MAIN PROGRAM'/) - WRITE (0, '(5X,A)') 'Input number corresponding to your selection:' - READ (5, '(I1)') IFUNC - GO TO (10,20,30,40,50,60) IFUNC - + ,10X,'5 - TRANSITION INTEGRALS'/,10X,'6 - EXIT TO MAIN PROGRAM'/) + WRITE (0, '(5X,A)') 'Input number corresponding to your selection:' + READ (5, '(I1)') IFUNC + GO TO (10,20,30,40,50,60) IFUNC + ! **** COMPUTE EXPECTATION VALUES - - 10 CONTINUE + + 10 CONTINUE WRITE (0, '(/5X,A,/A,T22,A)') & 'INPUT LABEL FOR ELECTRON FOLLOWED BY k: Example', ' 2p 3', & - 'FORMAT(1X,A3,I3) ' - READ (5, '(1X,A3,I3)') EL1, K - CALL EPTR (EL, EL1, I, J1) - IF (J1 == 1) GO TO 10 - RKEV = QUADR(I,I,K) - WRITE (3, 12) EL1, K, EL1, RKEV - WRITE (0, 12) EL1, K, EL1, RKEV - 12 FORMAT(/,15X,' VALUE OF <',A3,'|R**',I2,'|',A3,'> = ',1P,D14.7,' a.u.'/) - GO TO 4 - + 'FORMAT(1X,A3,I3) ' + READ (5, '(1X,A3,I3)') EL1, K + CALL EPTR (EL, EL1, I, J1) + IF (J1 == 1) GO TO 10 + RKEV = QUADR(I,I,K) + WRITE (3, 12) EL1, K, EL1, RKEV + WRITE (0, 12) EL1, K, EL1, RKEV + 12 FORMAT(/,15X,' VALUE OF <',A3,'|R**',I2,'|',A3,'> = ',1P,D14.7,' a.u.'/) + GO TO 4 + ! **** DETERMINE SLATER INTEGRALS FK, GK, RK, NK, MK, VK - - - 20 CONTINUE + + + 20 CONTINUE WRITE (0, '(/5X,A/A,T22,A)') & 'INPUT PARAMETERS FOR Fk,Gk,Rk,Nk,Mk or Vk INTEGRAL: Example', & - 'F 0( 1s, 2s)', 'FORMAT: (A1,I2,1X,4(A3,1X)) ' - READ (5, '(A1,I2,1X,4(A3,1X))') FUNC, K, EL1, EL2, EL3, EL4 + 'F 0( 1s, 2s)', 'FORMAT: (A1,I2,1X,4(A3,1X)) ' + READ (5, '(A1,I2,1X,4(A3,1X))') FUNC, K, EL1, EL2, EL3, EL4 IF (FUNC>='a' .AND. FUNC<='z') FUNC = CHAR(ICHAR(FUNC) + ICHAR('A') - & - ICHAR('a')) - CALL EPTR (EL, EL1, I1, J2) - IF (J2 == 1) GO TO 20 - CALL EPTR (EL, EL2, I2, J3) - IF (J3 == 1) GO TO 20 - IF (EL3 /= ' ') THEN - CALL EPTR (EL, EL3, I3, J4) - IF (J4 == 1) GO TO 20 - ENDIF - IF (EL4 /= ' ') THEN - CALL EPTR (EL, EL4, I4, J5) - IF (J5 == 1) GO TO 20 - ENDIF - SELECT CASE (FUNC) - CASE ('F') - SI = FK(I1,I2,K,REL) - CASE ('G') - SI = GK(I1,I2,K,REL) - CASE ('R') - SI = RK(I1,I2,I3,I4,K,REL) - CASE ('N') - SI = SN(I1,I2,I2,I1,K) - CASE ('M') - SI = SN(I1,I2,I1,I2,K) - CASE ('V') - SI = VK(I1,I2,I2,I1,K) - VK(I2,I1,I1,I2,K) - CASE DEFAULT - WRITE (0, 41) - 41 FORMAT(15X,'INTEGRAL UNKNOWN: RE-ENTER') - GO TO 20 - END SELECT - IF (FUNC /= 'R') THEN - WRITE (3, 25) FUNC, K, EL1, EL2, SI, 219474.D0*SI - WRITE (0, 25) FUNC, K, EL1, EL2, SI, 219474.D0*SI + ICHAR('a')) + CALL EPTR (EL, EL1, I1, J2) + IF (J2 == 1) GO TO 20 + CALL EPTR (EL, EL2, I2, J3) + IF (J3 == 1) GO TO 20 + IF (EL3 /= ' ') THEN + CALL EPTR (EL, EL3, I3, J4) + IF (J4 == 1) GO TO 20 + ENDIF + IF (EL4 /= ' ') THEN + CALL EPTR (EL, EL4, I4, J5) + IF (J5 == 1) GO TO 20 + ENDIF + SELECT CASE (FUNC) + CASE ('F') + SI = FK(I1,I2,K,REL) + CASE ('G') + SI = GK(I1,I2,K,REL) + CASE ('R') + SI = RK(I1,I2,I3,I4,K,REL) + CASE ('N') + SI = SN(I1,I2,I2,I1,K) + CASE ('M') + SI = SN(I1,I2,I1,I2,K) + CASE ('V') + SI = VK(I1,I2,I2,I1,K) - VK(I2,I1,I1,I2,K) + CASE DEFAULT + WRITE (0, 41) + 41 FORMAT(15X,'INTEGRAL UNKNOWN: RE-ENTER') + GO TO 20 + END SELECT + IF (FUNC /= 'R') THEN + WRITE (3, 25) FUNC, K, EL1, EL2, SI, 219474.D0*SI + WRITE (0, 25) FUNC, K, EL1, EL2, SI, 219474.D0*SI 25 FORMAT(/,15X,'INTEGRAL ',A1,I2,'(',A3,',',A3,') = ',1P,D14.7,' a.u.'/& - ,40X,0P,F14.3,' cm-1'/) - ELSE - WRITE (3, 26) FUNC, K, EL1, EL2, EL3, EL4, SI, 219474.D0*SI - WRITE (0, 26) FUNC, K, EL1, EL2, EL3, EL4, SI, 219474.D0*SI + ,40X,0P,F14.3,' cm-1'/) + ELSE + WRITE (3, 26) FUNC, K, EL1, EL2, EL3, EL4, SI, 219474.D0*SI + WRITE (0, 26) FUNC, K, EL1, EL2, EL3, EL4, SI, 219474.D0*SI 26 FORMAT(/,15X,'INTEGRAL ',A1,I2,'(',2A3,',',2A3,') = ',1P,D14.7,& - ' a.u.'/,46X,0P,F14.3,' cm-1'/) - ENDIF - GO TO 4 - + ' a.u.'/,46X,0P,F14.3,' cm-1'/) + ENDIF + GO TO 4 + ! **** COMPUTE ELECTRON DENSITY AT THE NUCLEUS - - 30 CONTINUE + + 30 CONTINUE WRITE (0, '(/5X,A/A,T22,A)') & 'INPUT IDENTIFYING LABEL FOR ELECTRON: Example', ' 1s', & - 'FORMAT(1X,A3) ' - READ (5, '(1X,A3)') EL1 - CALL EPTR (EL, EL1, I, J6) - IF (J6 == 1) GO TO 30 - LL = L(I) - IF (LL == 0) THEN - D = AZ(I)**2 - ELSE - D = 0 - ENDIF - WRITE (3, 32) EL1, D - WRITE (0, 32) EL1, D - 32 FORMAT(/,15X,'DENSITY AT THE NUCLEUS FOR ',A3,' = ',1P,D14.7,' a.u.'/) - GO TO 4 - + 'FORMAT(1X,A3) ' + READ (5, '(1X,A3)') EL1 + CALL EPTR (EL, EL1, I, J6) + IF (J6 == 1) GO TO 30 + LL = L(I) + IF (LL == 0) THEN + D = AZ(I)**2 + ELSE + D = 0 + ENDIF + WRITE (3, 32) EL1, D + WRITE (0, 32) EL1, D + 32 FORMAT(/,15X,'DENSITY AT THE NUCLEUS FOR ',A3,' = ',1P,D14.7,' a.u.'/) + GO TO 4 + ! **** COMPUTE SPIN-ORBIT PARAMETER - - 40 CONTINUE + + 40 CONTINUE WRITE (0, '(/,5X,A/A,T22,A)') & 'INPUT IDENTIFYING LABEL FOR ELECTRON: Example', ' 2p', & - 'FORMAT(1X,A3) ' - READ (5, '(1X,A3)') EL1 - CALL EPTR (EL, EL1, I, J7) - IF (J7 == 1) GO TO 40 - ZETA = 0.D0 - IF (L(I) /= 0) ZETA = BWZETA(I) - ZETACM = 219474*ZETA - WRITE (3, 43) EL1, ZETA, ZETACM - WRITE (0, 43) EL1, ZETA, ZETACM + 'FORMAT(1X,A3) ' + READ (5, '(1X,A3)') EL1 + CALL EPTR (EL, EL1, I, J7) + IF (J7 == 1) GO TO 40 + ZETA = 0.D0 + IF (L(I) /= 0) ZETA = BWZETA(I) + ZETACM = 219474*ZETA + WRITE (3, 43) EL1, ZETA, ZETACM + WRITE (0, 43) EL1, ZETA, ZETACM 43 FORMAT(/,15X,'SPIN-ORBIT PARAMETER FOR ',A3,' = ',1P,D14.7,' a.u.'/,46X,& - 0P,F14.3,' cm-1'/) - GO TO 4 - + 0P,F14.3,' cm-1'/) + GO TO 4 + ! **** COMPUTE TRANSITION INTEGRALS - - 50 CONTINUE + + 50 CONTINUE WRITE (0, '(/5X,A/A,T22,A)') & 'INPUT IDENTIFYING LABELS AND POWER OF R: Example', 'T 1( 2s, 2p)', & - 'FORMAT: (A1,I2,2(1X,A3)) ' - READ (5, '(A1,I2,1X,A3,1X,A3)') FUNC, K, EL1, EL2 - CALL EPTR (EL, EL1, I1, J8) - IF (J8 == 1) GO TO 50 - CALL EPTR (EL, EL2, I2, J9) - IF (J9 == 1) GO TO 50 - TI = QUADR(I1,I2,K) - WRITE (3, 52) FUNC, K, EL1, EL2, TI - WRITE (0, 52) FUNC, K, EL1, EL2, TI - 52 FORMAT(/,15X,'INTEGRAL ',A1,I2,'(',A3,',',A3,') = ',1P,D14.7,' a.u.'/) - GO TO 4 - 60 CONTINUE - RETURN - END SUBROUTINE MENU + 'FORMAT: (A1,I2,2(1X,A3)) ' + READ (5, '(A1,I2,1X,A3,1X,A3)') FUNC, K, EL1, EL2 + CALL EPTR (EL, EL1, I1, J8) + IF (J8 == 1) GO TO 50 + CALL EPTR (EL, EL2, I2, J9) + IF (J9 == 1) GO TO 50 + TI = QUADR(I1,I2,K) + WRITE (3, 52) FUNC, K, EL1, EL2, TI + WRITE (0, 52) FUNC, K, EL1, EL2, TI + 52 FORMAT(/,15X,'INTEGRAL ',A1,I2,'(',A3,',',A3,') = ',1P,D14.7,' a.u.'/) + GO TO 4 + 60 CONTINUE + RETURN + END SUBROUTINE MENU ! ! ------------------------------------------------------------------ ! M E T H O D @@ -3553,152 +3553,152 @@ END SUBROUTINE MENU ! which is both positive near the origin and has the required ! number of nodes. ! - SUBROUTINE METHD1(I) + SUBROUTINE METHD1(I) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE COEFF_C - USE WAVE_C - USE RADIAL_C, ONLY: L, N - USE PARAM_C - USE LABEL_C, ONLY: EL + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE COEFF_C + USE WAVE_C + USE RADIAL_C, ONLY: L, N + USE PARAM_C + USE LABEL_C, ONLY: EL USE DE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE solve_I - USE nodec_I + USE solve_I + USE nodec_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MN, NC, J - REAL(DOUBLE) :: DEL, EDP - LOGICAL :: V2, FIRST + INTEGER :: MN, NC, J + REAL(DOUBLE) :: DEL, EDP + LOGICAL :: V2, FIRST !----------------------------------------------- - FIRST = .TRUE. - FAIL = .FALSE. - EM = D0 - EU = ((Z - DMIN1(D5*S(I),D2*S(I)))/N(I))**2 - FU = EU - MK = 0 - 17 CONTINUE - CALL SOLVE (I, FIRST, REL) + FIRST = .TRUE. + FAIL = .FALSE. + EM = D0 + EU = ((Z - DMIN1(D5*S(I),D2*S(I)))/N(I))**2 + FU = EU + MK = 0 + 17 CONTINUE + CALL SOLVE (I, FIRST, REL) ! ! ***** IF KK EQUALS 3, OMIT THE NODE CHECKING ! - IF (KK /= 3) THEN + IF (KK /= 3) THEN ! ! ***** COUNT THE NUMBER OF NODES ! - MN = M - NC = NODEC(MN) + MN = M + NC = NODEC(MN) IF (TRACE) WRITE (6, 99) EL(I), NC, MN, NJ, PDE(MN), ED, EU, EM, & - DELTAE + DELTAE 99 FORMAT(2X,A3,' NC =',I3,' MN =',I3,' NJ =',I3,' PDE(MN) =',D10.2,& - ' ED =',D10.2,' EU =',D10.2,' EM =',D10.2,' DELTAE =',D10.2) + ' ED =',D10.2,' EU =',D10.2,' EM =',D10.2,' DELTAE =',D10.2) ! ! ***** IF NODE COUNT IS OFF BY NO MORE THAN 1 AND DELTAE IS STILL ! ***** QUITE LARGE, APPLY THE DELTAE CORRECTION ! - IF (IABS(NC - NODE)==1 .AND. DABS(DELTAE/ED)>0.02D0) GO TO 46 + IF (IABS(NC - NODE)==1 .AND. DABS(DELTAE/ED)>0.02D0) GO TO 46 ! ! ***** BRANCH ACCORDING TO WHETHER THE NODE COUNT IS TOO SMALL, ! ***** JUST RIGHT, OR TOO LARGE ! - IF (NC - NODE < 0) GO TO 8 - IF (NC - NODE > 0) GO TO 10 - V2 = DABS(DELTAE)<1.D-3 .OR. DABS(DELTAE)/ED<1.D-5 - IF (PDE(MN) 0) GO TO 10 + V2 = DABS(DELTAE)<1.D-3 .OR. DABS(DELTAE)/ED<1.D-5 + IF (PDE(MN)= EU) ED = D5*(EU + EDP) - IF (ED <= EM) ED = D5*(EM + EDP) - 33 CONTINUE - MK = MK + 1 - IF (EU <= EM) WRITE (6, 30) EM, EU, ED + 11 CONTINUE + EDP = ED + ED = ED*((L(I)+1+NC)/FN)**2.5 + IF (ED >= EU) ED = D5*(EU + EDP) + IF (ED <= EM) ED = D5*(EM + EDP) + 33 CONTINUE + MK = MK + 1 + IF (EU <= EM) WRITE (6, 30) EM, EU, ED 30 FORMAT(6X,'WARNING: DIFFICULTY WITH NODE COUNTING PROCEDURE'/,6X,& 'LOWER BOUND ON ED GREATER THAN UPPER BOUND'/,6X,'EL = ',F10.6,& - ' EU = ',F10.6,' ED = ',F10.6) - FIRST = .FALSE. - IF (MK>3*N(I) .OR. EU-EM= 0.05D0) THEN + IF (DABS(PDE(J))/DM >= 0.05D0) THEN ! ! ***** CHECK IF THIS IS THE FIRST SIGNIFICANT MAXIMUM ! - IF (SIGN == 0.D0) THEN - M = J - ELSE + IF (SIGN == 0.D0) THEN + M = J + ELSE ! ! ***** IF NOT THE FIRST, TEST WHETHER A SIGN CHANGE HAS ! OCCURRED SINCE THE LAST SIGNIFICANT MAX OR MIN ! - IF (PDE(J)*SIGN > 0.D0) GO TO 1002 - NCC = NCC + 1 - ENDIF + IF (PDE(J)*SIGN > 0.D0) GO TO 1002 + NCC = NCC + 1 + ENDIF ! ! ***** RESET FOR THE NEXT NODE ! - SIGN = PDE(J) - ENDIF - ENDIF - 1002 CONTINUE - DIFF1 = DIFF2 - END DO - NODEC = NCC - RETURN - END FUNCTION NODEC + SIGN = PDE(J) + ENDIF + ENDIF + 1002 CONTINUE + DIFF1 = DIFF2 + END DO + NODEC = NCC + RETURN + END FUNCTION NODEC ! @@ -3898,69 +3898,69 @@ END FUNCTION NODEC ! orthogonality constraint applies. A Gram-Schmidt type of process ! is used. ! - SUBROUTINE ORTHOG + SUBROUTINE ORTHOG !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE de_C - USE TEST_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: E - USE LABEL_C, ONLY: EL - USE COEFF_C + USE TEST_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: E + USE LABEL_C, ONLY: EL + USE COEFF_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quadr_I + USE quadr_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II, I, J, JJ - REAL(DOUBLE) :: PNN - LOGICAL :: CHANGE + INTEGER :: II, I, J, JJ + REAL(DOUBLE) :: PNN + LOGICAL :: CHANGE !----------------------------------------------- ! - IF (NWF==1 .OR. IB>NWF) RETURN - WRITE (6, 26) - 26 FORMAT(/) - II = MAX0(2,IB) - DO I = II, NWF - CHANGE = .FALSE. - AZZ = AZ(I) - DO J = 1, I - 1 - IF (E(I,J) == D0) CYCLE + IF (NWF==1 .OR. IB>NWF) RETURN + WRITE (6, 26) + 26 FORMAT(/) + II = MAX0(2,IB) + DO I = II, NWF + CHANGE = .FALSE. + AZZ = AZ(I) + DO J = 1, I - 1 + IF (E(I,J) == D0) CYCLE ! ! ORTHOGONALITY CONDITION APPLIES ! - C = QUADR(I,J,0) - IF (DABS(C) <= 1.D-10) CYCLE - WRITE (6, 63) EL(J), EL(I), C - 63 FORMAT(6X,'<',A3,'|',A3,'>=',1P,D8.1) - M = MAX0(M,MAX(J)) - P(:M,I) = P(:M,I) - C*P(:M,J) - AZZ = AZZ - C*AZ(J) - CHANGE = .TRUE. - END DO - IF (.NOT.CHANGE) CYCLE - PNN = DSQRT(QUADR(I,I,0)) - IF (P(1,I) < D0) PNN = -PNN - P(:M,I) = P(:M,I)/PNN - AZZ = AZZ/PNN - M = NO - 67 CONTINUE - IF (DABS(P(M,I)) < 1.D-15) THEN - P(M,I) = D0 - M = M - 1 - GO TO 67 - ENDIF - MAX(I) = M - AZ(I) = AZZ - END DO - RETURN - END SUBROUTINE ORTHOG + C = QUADR(I,J,0) + IF (DABS(C) <= 1.D-10) CYCLE + WRITE (6, 63) EL(J), EL(I), C + 63 FORMAT(6X,'<',A3,'|',A3,'>=',1P,D8.1) + M = MAX0(M,MAX(J)) + P(:M,I) = P(:M,I) - C*P(:M,J) + AZZ = AZZ - C*AZ(J) + CHANGE = .TRUE. + END DO + IF (.NOT.CHANGE) CYCLE + PNN = DSQRT(QUADR(I,I,0)) + IF (P(1,I) < D0) PNN = -PNN + P(:M,I) = P(:M,I)/PNN + AZZ = AZZ/PNN + M = NO + 67 CONTINUE + IF (DABS(P(M,I)) < 1.D-15) THEN + P(M,I) = D0 + M = M - 1 + GO TO 67 + ENDIF + MAX(I) = M + AZ(I) = AZZ + END DO + RETURN + END SUBROUTINE ORTHOG ! ! ------------------------------------------------------------------ ! O U T P U T @@ -3970,88 +3970,88 @@ END SUBROUTINE ORTHOG ! if PRINT is .TRUE. The functions will also be punched (or ! stored) on unit OUF, if OUF .NE. 0. ! - SUBROUTINE OUTPUT(PRINT) + SUBROUTINE OUTPUT(PRINT) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE INOUT_C - USE WAVE_C - USE PARAM_C - USE RADIAL_C, ONLY: R, R2, P, AZ, MAX - USE LABEL_C, ONLY: EL, ATOM, TERM + USE vast_kind_param, ONLY: DOUBLE + USE INOUT_C + USE WAVE_C + USE PARAM_C + USE RADIAL_C, ONLY: R, R2, P, AZ, MAX + USE LABEL_C, ONLY: EL, ATOM, TERM IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL , INTENT(IN) :: PRINT + LOGICAL , INTENT(IN) :: PRINT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ML, MU, I, MX, J, K, KK, JJ, IJ - REAL(DOUBLE), DIMENSION(8) :: OUT + INTEGER :: ML, MU, I, MX, J, K, KK, JJ, IJ + REAL(DOUBLE), DIMENSION(8) :: OUT !----------------------------------------------- - IF (PRINT) THEN + IF (PRINT) THEN OPEN(Unit=50,FILE='plot.dat',STATUS='UNKNOWN',FORM='FORMATTED') ! ! ***** PRINT RADIAL FUNCTIONS, 8 PER PAGE ! - ML = IB - 2 CONTINUE - MU = MIN0(ML + 7,NWF) - I = MU - ML + 1 - MX = 0 - DO J = ML, MU - MX = MAX0(MX,MAX(J)) - END DO - WRITE (3, 5) ATOM, TERM, (EL(J),J=ML,MU) + ML = IB + 2 CONTINUE + MU = MIN0(ML + 7,NWF) + I = MU - ML + 1 + MX = 0 + DO J = ML, MU + MX = MAX0(MX,MAX(J)) + END DO + WRITE (3, 5) ATOM, TERM, (EL(J),J=ML,MU) WRITE (50, *) WRITE (50, '(5X,"R",4X,8(3X,A3,4X))') (EL(J),J=ML,MU) - WRITE (50, 11) D0, (D0, J=ML,MU) - 5 FORMAT('1',9X,'WAVE FUNCTIONS FOR ',2A6,/,/,10X,'R',8(10X,A3)) - K = 0 - KK = 0 - DO J = 1, MX - OUT(:MU-ML+1) = P(J,ML:MU)*R2(J) - K = K + 1 - IF (K > 10) THEN - K = 1 - KK = KK + 1 - IF (KK >= 5) THEN - KK = 0 - WRITE (3, 23) - 23 FORMAT('1'/,/) - ELSE - WRITE (3, 8) - 8 FORMAT(1X) - ENDIF - ENDIF - WRITE (3, 10) R(J), (OUT(JJ),JJ=1,I) - WRITE (50,11) R(J), (OUT(JJ),JJ=1,I) - END DO - 10 FORMAT(F12.5,F12.6,7F11.6) - 11 FORMAT(1P,9E10.2) - OUT(:MU-ML+1) = DPM(ML:MU) - WRITE (3, 16) (OUT(J),J=1,I) - 16 FORMAT(3X,'MAX. DIFF.',F12.7,7F11.7) - ML = ML + 8 - IF (ML <= NWF) GO TO 2 + WRITE (50, 11) D0, (D0, J=ML,MU) + 5 FORMAT('1',9X,'WAVE FUNCTIONS FOR ',2A6,/,/,10X,'R',8(10X,A3)) + K = 0 + KK = 0 + DO J = 1, MX + OUT(:MU-ML+1) = P(J,ML:MU)*R2(J) + K = K + 1 + IF (K > 10) THEN + K = 1 + KK = KK + 1 + IF (KK >= 5) THEN + KK = 0 + WRITE (3, 23) + 23 FORMAT('1'/,/) + ELSE + WRITE (3, 8) + 8 FORMAT(1X) + ENDIF + ENDIF + WRITE (3, 10) R(J), (OUT(JJ),JJ=1,I) + WRITE (50,11) R(J), (OUT(JJ),JJ=1,I) + END DO + 10 FORMAT(F12.5,F12.6,7F11.6) + 11 FORMAT(1P,9E10.2) + OUT(:MU-ML+1) = DPM(ML:MU) + WRITE (3, 16) (OUT(J),J=1,I) + 16 FORMAT(3X,'MAX. DIFF.',F12.7,7F11.7) + ML = ML + 8 + IF (ML <= NWF) GO TO 2 CLOSE (UNIT=50) - ENDIF - - IF (OUF /= 0) THEN + ENDIF + + IF (OUF /= 0) THEN ! ! ***** OUTPUT FUNCTIONS ON UNIT OUF FOR FUTURE INPUT ! - DO I = 1, NWF - MX = MAX(I) + DO I = 1, NWF + MX = MAX(I) WRITE (OUF) ATOM, TERM, EL(I), MX, Z, E(I,I), EK(I), AZ(I), (P(J,I)& - ,J=1,MX) - END DO - ENDIF + ,J=1,MX) + END DO + ENDIF ! - RETURN - END SUBROUTINE OUTPUT + RETURN + END SUBROUTINE OUTPUT ! ! ------------------------------------------------------------------ ! P O T L @@ -4062,41 +4062,41 @@ END SUBROUTINE OUTPUT ! YR = SUM a Y (j,j;r) ! j,k ijk ! - SUBROUTINE POTL(I, REL) + SUBROUTINE POTL(I, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE RADIAL_C - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE RADIAL_C + USE PARAM_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE a_I - USE ykf_I + USE a_I + USE ykf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - LOGICAL :: REL + INTEGER :: I + LOGICAL :: REL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, K, JJ - REAL(DOUBLE) :: C -!----------------------------------------------- - YR(:NO) = D0 - DO J = 1, NWF - DO K = 0, 2*MIN0(L(I),L(J)), 2 - C = A(I,J,K) - IF (DABS(C) <= 1.D-8) CYCLE - CALL YKF (J, J, K, REL) - YR(:NO) = YR(:NO) + C*YK(:NO) - END DO - END DO - RETURN - END SUBROUTINE POTL + INTEGER :: J, K, JJ + REAL(DOUBLE) :: C +!----------------------------------------------- + YR(:NO) = D0 + DO J = 1, NWF + DO K = 0, 2*MIN0(L(I),L(J)), 2 + C = A(I,J,K) + IF (DABS(C) <= 1.D-8) CYCLE + CALL YKF (J, J, K, REL) + YR(:NO) = YR(:NO) + C*YK(:NO) + END DO + END DO + RETURN + END SUBROUTINE POTL ! ! ------------------------------------------------------------------ ! Q U A D @@ -4109,33 +4109,33 @@ END SUBROUTINE POTL ! r . ! M ! - REAL(KIND(0.0D0)) FUNCTION QUAD (I, M, F, G) + REAL(KIND(0.0D0)) FUNCTION QUAD (I, M, F, G) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I, M - REAL(DOUBLE) , INTENT(IN) :: F(NOD), G(NOD) + INTEGER , INTENT(IN) :: I, M + REAL(DOUBLE) , INTENT(IN) :: F(NOD), G(NOD) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J - REAL(DOUBLE) :: D, QUAD2 + INTEGER :: J + REAL(DOUBLE) :: D, QUAD2 !----------------------------------------------- - D = (D1 + D5*Z*R(1))/(H1*(2*L(I)+3)) - QUAD = RR(1)*F(1)*G(1)*(D - D5) - QUAD2 = D0 - QUAD = QUAD + DOT_PRODUCT(RR(:M-1:2)*F(:M-1:2),G(:M-1:2)) - QUAD2 = QUAD2 + DOT_PRODUCT(RR(2:M:2)*F(2:M:2),G(2:M:2)) - QUAD = H1*(QUAD + D2*QUAD2) - RETURN - END FUNCTION QUAD + D = (D1 + D5*Z*R(1))/(H1*(2*L(I)+3)) + QUAD = RR(1)*F(1)*G(1)*(D - D5) + QUAD2 = D0 + QUAD = QUAD + DOT_PRODUCT(RR(:M-1:2)*F(:M-1:2),G(:M-1:2)) + QUAD2 = QUAD2 + DOT_PRODUCT(RR(2:M:2)*F(2:M:2),G(2:M:2)) + QUAD = H1*(QUAD + D2*QUAD2) + RETURN + END FUNCTION QUAD ! ! ------------------------------------------------------------------ ! Q U A D R @@ -4145,43 +4145,43 @@ END FUNCTION QUAD ! Evaluates the integral of r P (r) P (r) with respect to r ! i j ! - REAL(KIND(0.0D0)) FUNCTION QUADR (I, J, KK) + REAL(KIND(0.0D0)) FUNCTION QUADR (I, J, KK) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I, J, KK + INTEGER , INTENT(IN) :: I, J, KK !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, LI, LJ, M, JJ, JP - REAL(DOUBLE) :: DEN, ZR, BI, BJ, ALPHA, BETA, D, DD -!----------------------------------------------- - K = KK + 2 - LI = L(I) - LJ = L(J) - DEN = LI + LJ + 1 + K - ZR = Z*R(4) - BI = (P(4,I)/(AZ(I)*R2(4)*R(4)**LI)-D1+ZR/(LI+1))/ZR**2 - BJ = (P(4,J)/(AZ(J)*R2(4)*R(4)**LJ)-D1+ZR/(LJ+1))/ZR**2 - ALPHA = (D1/(LI + 1) + D1/(LJ + 1))/(DEN + D1) - ZR = Z*R(1) + INTEGER :: K, LI, LJ, M, JJ, JP + REAL(DOUBLE) :: DEN, ZR, BI, BJ, ALPHA, BETA, D, DD +!----------------------------------------------- + K = KK + 2 + LI = L(I) + LJ = L(J) + DEN = LI + LJ + 1 + K + ZR = Z*R(4) + BI = (P(4,I)/(AZ(I)*R2(4)*R(4)**LI)-D1+ZR/(LI+1))/ZR**2 + BJ = (P(4,J)/(AZ(J)*R2(4)*R(4)**LJ)-D1+ZR/(LJ+1))/ZR**2 + ALPHA = (D1/(LI + 1) + D1/(LJ + 1))/(DEN + D1) + ZR = Z*R(1) BETA = (DEN + D1)*ALPHA**2 - D2*(BI + BJ + D1/((LI + 1)*(LJ + 1)))/(DEN& - + D2) - D = P(1,I)*P(1,J)*R(1)**K*(((BETA*ZR + ALPHA)*ZR + D1)/(DEN*H1) + D5) - DD = D0 - M = MIN0(MAX(I),MAX(J)) - 1 - D = D + DOT_PRODUCT(P(3:M+1:2,I)*P(3:M+1:2,J),R(3:M+1:2)**K) - DD = DD + DOT_PRODUCT(P(2:M:2,I)*P(2:M:2,J),R(2:M:2)**K) - QUADR = H1*(D + D2*DD) - RETURN - END FUNCTION QUADR + + D2) + D = P(1,I)*P(1,J)*R(1)**K*(((BETA*ZR + ALPHA)*ZR + D1)/(DEN*H1) + D5) + DD = D0 + M = MIN0(MAX(I),MAX(J)) - 1 + D = D + DOT_PRODUCT(P(3:M+1:2,I)*P(3:M+1:2,J),R(3:M+1:2)**K) + DD = DD + DOT_PRODUCT(P(2:M:2,I)*P(2:M:2,J),R(2:M:2)**K) + QUADR = H1*(D + D2*DD) + RETURN + END FUNCTION QUADR ! ! ------------------------------------------------------------------ ! Q U A D S @@ -4192,36 +4192,36 @@ END FUNCTION QUADR ! i j ! respect to r. ! - REAL(KIND(0.0D0)) FUNCTION QUADS (I, J, KK) + REAL(KIND(0.0D0)) FUNCTION QUADS (I, J, KK) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I, J, KK + INTEGER , INTENT(IN) :: I, J, KK !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, MX, M - REAL(DOUBLE) :: DEN, CD, D, DD + INTEGER :: K, MX, M + REAL(DOUBLE) :: DEN, CD, D, DD !----------------------------------------------- - DEN = L(I) + L(J) + 3 - K = 2 - KK - CD = D1 + Z*R(1)*(DEN - D1)/((DEN + D1)*((L(I)+1)*(L(J)+1))) - D = YK(1)*P(1,I)*P(1,J)*R(1)**K*(CD/(DEN*H1) + D5) - DD = D0 - MX = MIN0(MAX(I),MAX(J)) - 1 - DD = DD + DOT_PRODUCT(YK(2:MX:2)*P(2:MX:2,I)*P(2:MX:2,J),R(2:MX:2)**K) + DEN = L(I) + L(J) + 3 + K = 2 - KK + CD = D1 + Z*R(1)*(DEN - D1)/((DEN + D1)*((L(I)+1)*(L(J)+1))) + D = YK(1)*P(1,I)*P(1,J)*R(1)**K*(CD/(DEN*H1) + D5) + DD = D0 + MX = MIN0(MAX(I),MAX(J)) - 1 + DD = DD + DOT_PRODUCT(YK(2:MX:2)*P(2:MX:2,I)*P(2:MX:2,J),R(2:MX:2)**K) D = D + DOT_PRODUCT(YK(3:MX+1:2)*P(3:MX+1:2,I)*P(3:MX+1:2,J),R(3:MX+1:2)& - **K) - QUADS = H1*(D + D2*DD) - RETURN - END FUNCTION QUADS + **K) + QUADS = H1*(D + D2*DD) + RETURN + END FUNCTION QUADS ! ! ------------------------------------------------------------------ ! R E F O R M @@ -4230,44 +4230,44 @@ END FUNCTION QUADS ! Convert the free-format STR1 to the fixed 5(1X,A3,1X,I4,1X) format ! for STR2 ! - SUBROUTINE REFORM(STR1, STR2) + SUBROUTINE REFORM(STR1, STR2) IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: STR1*50 - CHARACTER , INTENT(OUT) :: STR2*50 + CHARACTER :: STR1*50 + CHARACTER , INTENT(OUT) :: STR2*50 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IS, JS + INTEGER :: I, IS, JS CHARACTER(LEN=50) :: BLANK = ' ' !----------------------------------------------- ! - 1 CONTINUE - I = 0 - STR2 = BLANK - IS = 0 - 2 CONTINUE - JS = INDEX(STR1(IS+1:),'(') - IF (JS /= 0) THEN - IF (JS > 5) GO TO 10 - I = I + 5 - STR2(I-JS+1:I) = STR1(IS+1:IS+JS) - IS = IS + JS - JS = INDEX(STR1(IS+1:),')') - IF (JS==0 .OR. JS>5) GO TO 10 - I = I + 5 - STR2(I-JS+1:I) = STR1(IS+1:IS+JS) - IS = IS + JS - GO TO 2 - ENDIF - RETURN - 10 CONTINUE - WRITE (0, *) ' Error in ', STR1, ': Re-enter' - READ (5, '(A)') STR1 - GO TO 1 - END SUBROUTINE REFORM + 1 CONTINUE + I = 0 + STR2 = BLANK + IS = 0 + 2 CONTINUE + JS = INDEX(STR1(IS+1:),'(') + IF (JS /= 0) THEN + IF (JS > 5) GO TO 10 + I = I + 5 + STR2(I-JS+1:I) = STR1(IS+1:IS+JS) + IS = IS + JS + JS = INDEX(STR1(IS+1:),')') + IF (JS==0 .OR. JS>5) GO TO 10 + I = I + 5 + STR2(I-JS+1:I) = STR1(IS+1:IS+JS) + IS = IS + JS + GO TO 2 + ENDIF + RETURN + 10 CONTINUE + WRITE (0, *) ' Error in ', STR1, ': Re-enter' + READ (5, '(A)') STR1 + GO TO 1 + END SUBROUTINE REFORM ! ! -------------------------------------------------------------------- ! R E O R D @@ -4276,34 +4276,34 @@ END SUBROUTINE REFORM ! Reorder the list of first appearance so that the functions to be ! iterated appear last in the list. ! - SUBROUTINE REORD(OF, ELC, NWF, IERR) + SUBROUTINE REORD(OF, ELC, NWF, IERR) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE eptr_I + USE eptr_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NWF - INTEGER , INTENT(OUT) :: IERR - CHARACTER(LEN=3) :: ELC + INTEGER , INTENT(IN) :: NWF + INTEGER , INTENT(OUT) :: IERR + CHARACTER(LEN=3) :: ELC CHARACTER(LEN=3), DIMENSION(:) :: OF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1, I, J + INTEGER :: J1, I, J !----------------------------------------------- ! - IERR = 1 - CALL EPTR (OF, ELC, I, J1) - IF (J1 == 1) GO TO 99 - OF(I:NWF-1) = OF(I+1:NWF) - OF(NWF) = ELC - IERR = 0 - 99 CONTINUE - RETURN - END SUBROUTINE REORD + IERR = 1 + CALL EPTR (OF, ELC, I, J1) + IF (J1 == 1) GO TO 99 + OF(I:NWF-1) = OF(I+1:NWF) + OF(NWF) = ELC + IERR = 0 + 99 CONTINUE + RETURN + END SUBROUTINE REORD ! ! ! ------------------------------------------------------------------ @@ -4313,78 +4313,78 @@ END SUBROUTINE REORD ! k ! Evaluates R (i, j; ii, jj) ! - REAL(KIND(0.0D0)) FUNCTION RK (I, J, II, JJ, K, REL) + REAL(KIND(0.0D0)) FUNCTION RK (I, J, II, JJ, K, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ykf_I - USE quads_I + USE ykf_I + USE quads_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J, II, JJ, K - LOGICAL :: REL + INTEGER :: I, J, II, JJ, K + LOGICAL :: REL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - CALL YKF (I, II, K, REL) - RK = QUADS(J,JJ,1) - RETURN - END FUNCTION RK + CALL YKF (I, II, K, REL) + RK = QUADS(J,JJ,1) + RETURN + END FUNCTION RK ! ! ------------------------------------------------------------------ ! R M E ! ------------------------------------------------------------------ ! ! - REAL(KIND(0.0D0)) FUNCTION RME (L, LP, K) + REAL(KIND(0.0D0)) FUNCTION RME (L, LP, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE FACT_C + USE vast_kind_param, ONLY: DOUBLE + USE FACT_C ! IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: L, LP, K + INTEGER , INTENT(IN) :: L, LP, K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I2G, IG, I1, I2, I3 - REAL(DOUBLE) :: QUSQRT + INTEGER :: I2G, IG, I1, I2, I3 + REAL(DOUBLE) :: QUSQRT !----------------------------------------------- ! !--- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP) - SEE FANO ! AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81 ! - IF (MIN0(L,LP) == 0) THEN - RME = 1.D0 - ELSE IF (K == 0) THEN - RME = 2*L + 1 - RME = DSQRT(RME) - ELSE - I2G = L + LP + K - IG = I2G/2 - IF (I2G - 2*IG /= 0) THEN - RME = 0.D0 - ELSE - I1 = IG - L - I2 = IG - LP - I3 = IG - K - QUSQRT = (2*L + 1)*(2*LP + 1) + IF (MIN0(L,LP) == 0) THEN + RME = 1.D0 + ELSE IF (K == 0) THEN + RME = 2*L + 1 + RME = DSQRT(RME) + ELSE + I2G = L + LP + K + IG = I2G/2 + IF (I2G - 2*IG /= 0) THEN + RME = 0.D0 + ELSE + I1 = IG - L + I2 = IG - LP + I3 = IG - K + QUSQRT = (2*L + 1)*(2*LP + 1) RME = DSQRT(QUSQRT)*DEXP((GAM(2*I1+1)+GAM(2*I2+1)+GAM(2*I3+1)-GAM(& - I2G+2))/2.D0+GAM(IG+1)-GAM(I1+1)-GAM(I2+1)-GAM(I3+1)) - ENDIF - ENDIF - RETURN - END FUNCTION RME + I2G+2))/2.D0+GAM(IG+1)-GAM(I1+1)-GAM(I2+1)-GAM(I3+1)) + ENDIF + ENDIF + RETURN + END FUNCTION RME ! ! ------------------------------------------------------------------ ! R O T A T E @@ -4397,111 +4397,111 @@ END FUNCTION RME ! the stationay condition to first order in the perturbation. ! ! - SUBROUTINE ROTATE(I, J) + SUBROUTINE ROTATE(I, J) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: E, SUM - USE LABEL_C, ONLY: EL - USE COEFF_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: E, SUM + USE LABEL_C, ONLY: EL + USE COEFF_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE hl_I - USE a_I - USE b_I - USE rk_I - USE fk_I - USE gk_I + USE hl_I + USE a_I + USE b_I + USE rk_I + USE fk_I + USE gk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J + INTEGER :: I + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, M, KK, JJ - REAL(DOUBLE) :: DG, C, FKII, FKIJ, GKIJ, CJ, FKJJ, EPS, DD, PI - REAL(DOUBLE) :: QI, QJ, G, DI, DJ, DII, DJJ, DIJ, DJI -!----------------------------------------------- - ALL = .TRUE. - G = D0 - DG = D0 - QI = SUM(I) - QJ = SUM(J) - IF (QI/=D2*(2*L(I)+1) .OR. QJ/=D2*(2*L(J)+1)) THEN - IF (DABS(QI - QJ) >= 1.D-14) THEN - C = D5*(QI - QJ) - G = G - C*HL(EL,I,J,REL) - DG = DG - C*(HL(EL,I,I,REL) - HL(EL,J,J,REL)) - ENDIF -! - DO K = 0, 2*L(I), 2 - C = QI*(A(I,I,K) - A(I,J,K) - B(I,J,K)) - IF (DABS(C) >= 1.D-8) THEN - G = G + C*RK(I,I,I,J,K,REL) - FKII = FK(I,I,K,REL) - FKIJ = FK(I,J,K,REL) - GKIJ = GK(I,J,K,REL) - DG = DG + C*(FKII - FKIJ - D2*GKIJ) - ENDIF - CJ = QJ*(A(J,J,K) - A(J,I,K) - B(J,I,K)) - IF (DABS(CJ) < 1.D-8) CYCLE - FKJJ = FK(J,J,K,REL) - IF (DABS(C) < 1.D-8) THEN - FKIJ = FK(I,J,K,REL) - GKIJ = GK(I,J,K,REL) - ENDIF - G = G - CJ*RK(J,J,J,I,K,REL) - DG = DG + CJ*(FKJJ - FKIJ - D2*GKIJ) - END DO - DO M = 1, NWF - IF (M==I .OR. M==J) CYCLE - DO K = 0, 2*MIN0(L(I),L(M)), 2 - C = A(I,M,K)*QI - A(J,M,K)*QJ - IF (DABS(C) >= 1.D-8) THEN - G = G + C*RK(I,M,J,M,K,REL) - DG = DG + C*(FK(I,M,K,REL) - FK(J,M,K,REL)) - ENDIF - KK = IABS(L(I)-L(M)) + K - C = B(I,M,KK)*QI - B(J,M,KK)*QJ - IF (DABS(C) < 1.D-8) CYCLE - G = G + C*RK(I,J,M,M,KK,REL) - DG = DG + C*(GK(I,M,KK,REL) - GK(J,M,KK,REL)) - END DO - END DO - IF (DABS(QI - QJ) + DABS(G) + DABS(DG) > 2.D-8) THEN - IF (DABS(G) + DABS(DG)>1.D-8 .OR. DABS(E(I,J))>2.D-5) THEN - EPS = G/DG - EPS = DSIGN(DMIN1(DABS(EPS),0.2D0),EPS) - DD = DSQRT(D1 + EPS*EPS) - DO JJ = 1, NO - PI = (P(JJ,I)+EPS*P(JJ,J))/DD - P(JJ,J) = (P(JJ,J)-EPS*P(JJ,I))/DD - P(JJ,I) = PI - END DO - ELSE - EPS = D0 - ENDIF - WRITE (6, 100) EL(I), EL(J), G, EL(I), EL(J), DG, EPS + INTEGER :: K, M, KK, JJ + REAL(DOUBLE) :: DG, C, FKII, FKIJ, GKIJ, CJ, FKJJ, EPS, DD, PI + REAL(DOUBLE) :: QI, QJ, G, DI, DJ, DII, DJJ, DIJ, DJI +!----------------------------------------------- + ALL = .TRUE. + G = D0 + DG = D0 + QI = SUM(I) + QJ = SUM(J) + IF (QI/=D2*(2*L(I)+1) .OR. QJ/=D2*(2*L(J)+1)) THEN + IF (DABS(QI - QJ) >= 1.D-14) THEN + C = D5*(QI - QJ) + G = G - C*HL(EL,I,J,REL) + DG = DG - C*(HL(EL,I,I,REL) - HL(EL,J,J,REL)) + ENDIF +! + DO K = 0, 2*L(I), 2 + C = QI*(A(I,I,K) - A(I,J,K) - B(I,J,K)) + IF (DABS(C) >= 1.D-8) THEN + G = G + C*RK(I,I,I,J,K,REL) + FKII = FK(I,I,K,REL) + FKIJ = FK(I,J,K,REL) + GKIJ = GK(I,J,K,REL) + DG = DG + C*(FKII - FKIJ - D2*GKIJ) + ENDIF + CJ = QJ*(A(J,J,K) - A(J,I,K) - B(J,I,K)) + IF (DABS(CJ) < 1.D-8) CYCLE + FKJJ = FK(J,J,K,REL) + IF (DABS(C) < 1.D-8) THEN + FKIJ = FK(I,J,K,REL) + GKIJ = GK(I,J,K,REL) + ENDIF + G = G - CJ*RK(J,J,J,I,K,REL) + DG = DG + CJ*(FKJJ - FKIJ - D2*GKIJ) + END DO + DO M = 1, NWF + IF (M==I .OR. M==J) CYCLE + DO K = 0, 2*MIN0(L(I),L(M)), 2 + C = A(I,M,K)*QI - A(J,M,K)*QJ + IF (DABS(C) >= 1.D-8) THEN + G = G + C*RK(I,M,J,M,K,REL) + DG = DG + C*(FK(I,M,K,REL) - FK(J,M,K,REL)) + ENDIF + KK = IABS(L(I)-L(M)) + K + C = B(I,M,KK)*QI - B(J,M,KK)*QJ + IF (DABS(C) < 1.D-8) CYCLE + G = G + C*RK(I,J,M,M,KK,REL) + DG = DG + C*(GK(I,M,KK,REL) - GK(J,M,KK,REL)) + END DO + END DO + IF (DABS(QI - QJ) + DABS(G) + DABS(DG) > 2.D-8) THEN + IF (DABS(G) + DABS(DG)>1.D-8 .OR. DABS(E(I,J))>2.D-5) THEN + EPS = G/DG + EPS = DSIGN(DMIN1(DABS(EPS),0.2D0),EPS) + DD = DSQRT(D1 + EPS*EPS) + DO JJ = 1, NO + PI = (P(JJ,I)+EPS*P(JJ,J))/DD + P(JJ,J) = (P(JJ,J)-EPS*P(JJ,I))/DD + P(JJ,I) = PI + END DO + ELSE + EPS = D0 + ENDIF + WRITE (6, 100) EL(I), EL(J), G, EL(I), EL(J), DG, EPS 100 FORMAT(10X,'C(',2A3,') =',F12.5,3X,'V(',2A3,') =',F12.5,3X,'EPS =',& - F9.6) - RETURN + F9.6) + RETURN ! ! ***** THE ENERGY IS STATIONARY WITH RESPECT TO ROTATIONS ! - ENDIF - ENDIF - E(I,J) = 1.D-10 - E(J,I) = 1.D-10 - RETURN - END SUBROUTINE ROTATE + ENDIF + ENDIF + E(I,J) = 1.D-10 + E(J,I) = 1.D-10 + RETURN + END SUBROUTINE ROTATE ! ! ------------------------------------------------------------------ ! S H I F T @@ -4512,98 +4512,98 @@ END SUBROUTINE ROTATE ! including non-diagonal corrections ! ! - REAL(KIND(0.0D0)) FUNCTION RLSHFT (I1, I2) + REAL(KIND(0.0D0)) FUNCTION RLSHFT (I1, I2) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I1 - INTEGER , INTENT(IN) :: I2 + INTEGER , INTENT(IN) :: I1 + INTEGER , INTENT(IN) :: I2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LL, L2, L3, MX, J, I, KK, MM, K + INTEGER :: LL, L2, L3, MX, J, I, KK, MM, K REAL(DOUBLE) :: FL, C, ZZ, HH, A1, B1, B2, YY, A2, A, B, RELSH, RELSH2, & - RLM, RLD + RLM, RLD !----------------------------------------------- ! ! ***** FORM DD -L(L+1)/RR|P(I)> ! - FL = L(I1) - C = (FL + D5)**2 - LL = L(I1) + 1 - L2 = 2*L(I1) + 1 - L3 = 2*L(I1) + 3 - ZZ = Z*Z - HH = 180.D0*H*H - MX = MAX0(MAX(I1),MAX(I2)) - YK(2:MX) = -D1/RR(2:MX) + FL = L(I1) + C = (FL + D5)**2 + LL = L(I1) + 1 + L2 = 2*L(I1) + 1 + L3 = 2*L(I1) + 3 + ZZ = Z*Z + HH = 180.D0*H*H + MX = MAX0(MAX(I1),MAX(I2)) + YK(2:MX) = -D1/RR(2:MX) ! ! ***** FORM THE INTEGRAND ! - I = I1 - A1 = D0 - B1 = D0 - DO KK = 1, 2 - B2 = B1 - YY = (P(3,I)+P(1,I)-D2*P(2,I))/(H*H) - C*P(2,I) - YK(2) = YY*YK(2) + I = I1 + A1 = D0 + B1 = D0 + DO KK = 1, 2 + B2 = B1 + YY = (P(3,I)+P(1,I)-D2*P(2,I))/(H*H) - C*P(2,I) + YK(2) = YY*YK(2) YK(3) = YK(3)*(((-(P(5,I)+P(1,I)))+D16*(P(4,I)+P(2,I))-D30*P(3,I))/(& - D12*H*H)-C*P(3,I)) - MM = MAX(I) - 3 - DO K = 4, MM - YY = D2*(P(K+3,I)+P(K-3,I)) - YY = YY - 27.D0*(P(K+2,I)+P(K-2,I)) - YY = YY + 270.D0*(P(K+1,I)+P(K-1,I)) - 490.D0*P(K,I) - YY = YY/HH - C*P(K,I) - YK(K) = YY*YK(K) - IF (K /= 4) CYCLE - B1 = (YY/(D2*Z*P(4,I)*R(4))+D1)/R(4) - END DO - MM = MM + 1 + D12*H*H)-C*P(3,I)) + MM = MAX(I) - 3 + DO K = 4, MM + YY = D2*(P(K+3,I)+P(K-3,I)) + YY = YY - 27.D0*(P(K+2,I)+P(K-2,I)) + YY = YY + 270.D0*(P(K+1,I)+P(K-1,I)) - 490.D0*P(K,I) + YY = YY/HH - C*P(K,I) + YK(K) = YY*YK(K) + IF (K /= 4) CYCLE + B1 = (YY/(D2*Z*P(4,I)*R(4))+D1)/R(4) + END DO + MM = MM + 1 YK(MM) = YK(MM)*(((-(P(MM+2,I)+P(MM-2,I)))+D16*(P(MM+1,I)+P(MM-1,I))-& - D30*P(MM,I))/(D12*H*H)-C*P(MM,I)) - MM = MM + 1 - YK(MM) = YK(MM)*((P(MM+1,I)+P(MM-1,I)-D2*P(MM,I))/(H*H)-C*P(MM,I)) - A2 = A1 - A1 = (P(1,I)/(AZ(I)*R(1)**L(I)*R2(1))-D1+Z*R(1)/LL)/RR(1) - I = I2 - END DO + D30*P(MM,I))/(D12*H*H)-C*P(MM,I)) + MM = MM + 1 + YK(MM) = YK(MM)*((P(MM+1,I)+P(MM-1,I)-D2*P(MM,I))/(H*H)-C*P(MM,I)) + A2 = A1 + A1 = (P(1,I)/(AZ(I)*R(1)**L(I)*R2(1))-D1+Z*R(1)/LL)/RR(1) + I = I2 + END DO ! ! ***** DETERMINE CONTRIBUTION FROM NEAR THE NUCLEUS ! - A = (Z/LL - L2*(B1 + B2)/D2)/LL + A = (Z/LL - L2*(B1 + B2)/D2)/LL B = (L2*B1*B2 - D2*(A1 + A2) + (Z/LL**2)*(D2*Z*(D1 + D1/LL) - L2*(B1 + B2& - )))/L3 - RELSH = -P(4,I1)*P(4,I2)*(D1 + A*R(4)+B*RR(4))*D4*ZZ/L2 - RELSH = RELSH/H1 - D5*YK(4) - RELSH2 = D0 + )))/L3 + RELSH = -P(4,I1)*P(4,I2)*(D1 + A*R(4)+B*RR(4))*D4*ZZ/L2 + RELSH = RELSH/H1 - D5*YK(4) + RELSH2 = D0 ! ! ***** INTEGRATE ! - RELSH2 = RELSH2 + SUM(YK(5:MX:2)) - RELSH = RELSH + SUM(YK(4:MX-1:2)) - RELSH = (RELSH + D2*RELSH2)*H1 - + RELSH2 = RELSH2 + SUM(YK(5:MX:2)) + RELSH = RELSH + SUM(YK(4:MX-1:2)) + RELSH = (RELSH + D2*RELSH2)*H1 + ! IF ( L(I1) .EQ. 0 ) RELSH = RELSH + Z*AZ(I1)*AZ(I2) ! RLSHFT = RELSH*D5*FINE - - RLM = RELSH*D5*FINE - RLD = 0.D0 - IF (L(I1) == 0) RLD = Z*AZ(I1)*AZ(I2)*D5*FINE - RLSHFT = RLM + RLD - + + RLM = RELSH*D5*FINE + RLD = 0.D0 + IF (L(I1) == 0) RLD = Z*AZ(I1)*AZ(I2)*D5*FINE + RLSHFT = RLM + RLD + ! write(3,'(a,4i4,a,3F10.5)') 'NL = ', N(i1),L(i1),N(i2),L(i2), ! : ' RLSHFT =', RLM,RLD,RLSHFT - - RETURN - END FUNCTION RLSHFT + + RETURN + END FUNCTION RLSHFT ! ! ------------------------------------------------------------------ ! S C A L E @@ -4614,82 +4614,82 @@ END FUNCTION RLSHFT ! values and the diagonal energy parameters are also scaled. ! ! - SUBROUTINE SCALE(ZZ) + SUBROUTINE SCALE(ZZ) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C - USE WAVE_C, ONLY: E, S + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C + USE WAVE_C, ONLY: E, S !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quadr_I + USE quadr_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: ZZ + REAL(DOUBLE) , INTENT(IN) :: ZZ !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, I ,K - REAL(DOUBLE) :: RATIO, SR, SC, SS, F0, F1, F2, F3, PNORM, THETA - REAL(DOUBLE), DIMENSION(NOD) :: RS, PS -!----------------------------------------------- - RATIO = Z/ZZ - SR = DSQRT(RATIO) - R(:NO) = R(:NO)*RATIO - RR(:NO) = R(:NO)*R(:NO) - R2(:NO) = R2(:NO)*SR - DO I = 1, NWF - SC = (ZZ - S(I))/(Z - S(I)) - SS = SC*RATIO - E(I,I) = E(I,I)*SC**2 - RS(:NO) = R(:NO)/SS - PS(:NO) = P(:NO,I)*SC - SC = (ZZ - D5*S(I))/(Z - D5*S(I)) - AZ(I) = AZ(I)*SC**(L(I)+1)*DSQRT(SC) - K = 3 + REAL(DOUBLE) :: RATIO, SR, SC, SS, F0, F1, F2, F3, PNORM, THETA + REAL(DOUBLE), DIMENSION(NOD) :: RS, PS +!----------------------------------------------- + RATIO = Z/ZZ + SR = DSQRT(RATIO) + R(:NO) = R(:NO)*RATIO + RR(:NO) = R(:NO)*R(:NO) + R2(:NO) = R2(:NO)*SR + DO I = 1, NWF + SC = (ZZ - S(I))/(Z - S(I)) + SS = SC*RATIO + E(I,I) = E(I,I)*SC**2 + RS(:NO) = R(:NO)/SS + PS(:NO) = P(:NO,I)*SC + SC = (ZZ - D5*S(I))/(Z - D5*S(I)) + AZ(I) = AZ(I)*SC**(L(I)+1)*DSQRT(SC) + K = 3 ! ! ***** INTERPOLATE THE (RS,PS) FUNCTIONS FOR VALUES OF P AT THE SET ! ***** OF POINTS R ! - DO J = 1, NO + DO J = 1, NO ! ! ***** SEARCH FOR THE NEAREST ENTRIES IN THE (RS,PS) TABLE ! - 5 CONTINUE - IF (K /= ND) THEN - IF (RS(K) > R(J)) GO TO 6 - K = K + 1 - GO TO 5 + 5 CONTINUE + IF (K /= ND) THEN + IF (RS(K) > R(J)) GO TO 6 + K = K + 1 + GO TO 5 ! ! ***** INTERPOLATE ! - 6 CONTINUE - THETA = DLOG(R(J)/RS(K-1))/H - F0 = PS(K-2) - F1 = PS(K-1) - F2 = PS(K) - F3 = PS(K+1) + 6 CONTINUE + THETA = DLOG(R(J)/RS(K-1))/H + F0 = PS(K-2) + F1 = PS(K-1) + F2 = PS(K) + F3 = PS(K+1) P(J,I) = D5*(F1 + F2) + (THETA - D5)*(F2 - F1) + THETA*(THETA - & - D1)*(F0 - F1 - F2 + F3)/D4 - ELSE - P(J,I) = D0 - ENDIF - END DO - MAX(I) = NO + D1)*(F0 - F1 - F2 + F3)/D4 + ELSE + P(J,I) = D0 + ENDIF + END DO + MAX(I) = NO ! ! ***** NORMALIZE THE INTERPOLATED FUNCTION ! - PNORM = DSQRT(QUADR(I,I,0)) - P(:NO,I) = P(:NO,I)/PNORM - END DO - Z = ZZ - RETURN - END SUBROUTINE SCALE + PNORM = DSQRT(QUADR(I,I,0)) + P(:NO,I) = P(:NO,I)/PNORM + END DO + Z = ZZ + RETURN + END SUBROUTINE SCALE ! @@ -4714,158 +4714,158 @@ END SUBROUTINE SCALE ! It is increased by a factor two at the end of each iteration. ! ! - SUBROUTINE SCF(ETOTAL, SCFTOL, EREL) + SUBROUTINE SCF(ETOTAL, SCFTOL, EREL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE LABEL_C - USE PARAM_C - USE WAVE_C, ONLY: SUM, DPM, IORD, IPR, NOD - USE INOUT_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE LABEL_C + USE PARAM_C + USE WAVE_C, ONLY: SUM, DPM, IORD, IPR, NOD + USE INOUT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE grange_I - USE de_I - USE orthog_I - USE help_I - USE energy_I + USE grange_I + USE de_I + USE orthog_I + USE help_I + USE energy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) :: ETOTAL - REAL(DOUBLE) , INTENT(IN) :: SCFTOL - REAL(DOUBLE) , INTENT(OUT) :: EREL + REAL(DOUBLE) :: ETOTAL + REAL(DOUBLE) , INTENT(IN) :: SCFTOL + REAL(DOUBLE) , INTENT(OUT) :: EREL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ICYCLE, I, JP, J, JJ, II, NIT - REAL(DOUBLE) :: Z2, DP1, DP, CFGTOL, ENONR - LOGICAL :: LAST - CHARACTER :: ANS + INTEGER :: ICYCLE, I, JP, J, JJ, II, NIT + REAL(DOUBLE) :: Z2, DP1, DP, CFGTOL, ENONR + LOGICAL :: LAST + CHARACTER :: ANS !----------------------------------------------- ! ! ***** SET THE SCF CONVERGENCE PARAMETER TO AN OPTIMISTIC VALUE ! - REL = .FALSE. - TOL = DSQRT(Z)*1.D-10 - Z2 = SCFTOL*DSQRT(Z*NWF) - WRITE (6, 15) - 15 FORMAT(/,/) - WRITE (6, 16) OMIT, SCFTOL, NO + REL = .FALSE. + TOL = DSQRT(Z)*1.D-10 + Z2 = SCFTOL*DSQRT(Z*NWF) + WRITE (6, 15) + 15 FORMAT(/,/) + WRITE (6, 16) OMIT, SCFTOL, NO 16 FORMAT(10X,'WEAK ORTHOGONALIZATION DURING THE SCF CYCLE=',L4,/,10X,& 'SCF CONVERGENCE TOLERANCE (FUNCTIONS) =',1P,D9.2,/,10X,& - 'NUMBER OF POINTS IN THE MAXIMUM RANGE =',I4) + 'NUMBER OF POINTS IN THE MAXIMUM RANGE =',I4) ! ! ***** SET ITERATION PARAMETERS ! - IPR = 0 - DP1 = D0 - ETOTAL = D0 - ICYCLE = 0 - IF (IB <= NWF) THEN + IPR = 0 + DP1 = D0 + ETOTAL = D0 + ICYCLE = 0 + IF (IB <= NWF) THEN ! ! ***** PERFORM NSCF SELF-CONSISTENT FIELD ITERATIONS ! - LAST = .FALSE. - 9 CONTINUE - DO I = 1, NSCF - ICYCLE = ICYCLE + 1 - WRITE (6, 7) ICYCLE, Z2 + LAST = .FALSE. + 9 CONTINUE + DO I = 1, NSCF + ICYCLE = ICYCLE + 1 + WRITE (6, 7) ICYCLE, Z2 7 FORMAT(/,/,10X,'ITERATION NUMBER ',I2,/,10X,'----------------'/,/,& 10X,'SCF CONVERGENCE CRITERIA (SCFTOL*SQRT(Z*NWF)) = ',1P,D9.1,/& - ) - DP1 = D0 - CALL GRANGE + ) + DP1 = D0 + CALL GRANGE ! ! ***** SOLVE EACH DIFFERENTIAL EQUATION IN TURN ! - WRITE (6, 14) - 14 FORMAT(/,20X,' EL',9X,'ED',13X,'AZ',11X,'NORM',7X,'DPM') - DO JP = IB, NWF - J = IORD(JP) - CALL DE (J) - IF (FAIL) RETURN - DP = DPM(J)*DSQRT(SUM(J)) - IF (DP1 >= DP) CYCLE - DP1 = DP - JJ = J - END DO - IF (DP1 >= Z2) THEN + WRITE (6, 14) + 14 FORMAT(/,20X,' EL',9X,'ED',13X,'AZ',11X,'NORM',7X,'DPM') + DO JP = IB, NWF + J = IORD(JP) + CALL DE (J) + IF (FAIL) RETURN + DP = DPM(J)*DSQRT(SUM(J)) + IF (DP1 >= DP) CYCLE + DP1 = DP + JJ = J + END DO + IF (DP1 >= Z2) THEN ! ! ***** SOLVE IC DIFFERENTIAL EQUATIONS EACH TIME SELECTING THE ! ***** ONE WITH THE LARGEST DPM ! - DO II = 1, IC - CALL DE (JJ) - IF (FAIL) RETURN - DP1 = D0 - DO JP = IB, NWF - J = IORD(JP) - DP = DSQRT(SUM(J))*DPM(J) - IF (DP1 > DP) CYCLE - JJ = J - DP1 = DP - END DO - IF (DP1 >= Z2) CYCLE - EXIT - END DO - ENDIF - CALL ORTHOG - IF (DP1 DP) CYCLE + JJ = J + DP1 = DP + END DO + IF (DP1 >= Z2) CYCLE + EXIT + END DO + ENDIF + CALL ORTHOG + IF (DP1= EU) THEN - EU = D10*ED - FU = EU - ENDIF - AZD = AZ(I) - ENDIF - YR(:NO) = (YK(:NO)+ED*RR(:NO))*CH - ZERO(:NO) = D0 + ENDIF + ENDIF + IF (D10*ED >= EU) THEN + EU = D10*ED + FU = EU + ENDIF + AZD = AZ(I) + ENDIF + YR(:NO) = (YK(:NO)+ED*RR(:NO))*CH + ZERO(:NO) = D0 ! ! ***** SEARCH FOR THE POINT AT WHICH YR BECOMES POSITIVE ! - CALL SEARCH (NJ, I) + CALL SEARCH (NJ, I) ! ! ***** COMPUTE STARTING VALUES FROM SERIES EXPANSION ! - B3 = (V + V + ED - (Z/FN)**2)/C - DO J = 1, 2 - HW = HWF(N(I),L(I),Z,R(J))/CN - HQ(J) = AZD*(HW + R(J)**(L(I)+3)*B3*(D1-R(J)*B4))/R2(J) - END DO + B3 = (V + V + ED - (Z/FN)**2)/C + DO J = 1, 2 + HW = HWF(N(I),L(I),Z,R(J))/CN + HQ(J) = AZD*(HW + R(J)**(L(I)+3)*B3*(D1-R(J)*B4))/R2(J) + END DO ! ! ***** OBTAIN HOMOGENEOUS SOLUTION -! - CALL NMRVS (NJ, DELH, MH, HQ, ZERO) - PDE(1) = HQ(1) + XY/C - PDE(2) = HQ(2) + XP/C +! + CALL NMRVS (NJ, DELH, MH, HQ, ZERO) + PDE(1) = HQ(1) + XY/C + PDE(2) = HQ(2) + XP/C ! ! ***** OBTAIN PARTICULAR SOLUTION ! - CALL NMRVS (NJ, DEL1, M1, PDE, X) + CALL NMRVS (NJ, DEL1, M1, PDE, X) ! ! ***** DETERMINE THE ENERGY ADJUSTMENT REQUIRED FOR A SOLUTION WITH ! ***** GIVEN A0 ! - M = MAX0(M1,MH) - PNORM = D0 - PNORM = PNORM + DOT_PRODUCT(RR(:M)*HQ(:M),PDE(:M)) - Y1 = PDE(NJ-1) - Y2 = PDE(NJ) - Y3 = PDE(NJ+1) + M = MAX0(M1,MH) + PNORM = D0 + PNORM = PNORM + DOT_PRODUCT(RR(:M)*HQ(:M),PDE(:M)) + Y1 = PDE(NJ-1) + Y2 = PDE(NJ) + Y3 = PDE(NJ+1) DELTA = Y2 - Y1 + Y2 - Y3 + YR(NJ-1)*Y1 + D10*YR(NJ)*Y2 + YR(NJ+1)*Y3 + X& - (NJ) - DELTAE = HQ(NJ)*DELTA/(H*H*PNORM) - PP = -DEL1/DELH + (NJ) + DELTAE = HQ(NJ)*DELTA/(H*H*PNORM) + PP = -DEL1/DELH ! ! ***** MATCH AT THE JOIN FOR A SOLUTION OF THE DIFFERENTIAL EQUATION ! - PDE(:NO) = PDE(:NO) + PP*HQ(:NO) + PDE(:NO) = PDE(:NO) + PP*HQ(:NO) ! ! ***** IF THE EQUATIONS APPEAR TO BE NEARLY ! **** SINGULAR, SOLVE THE VARIATIONAL EQUATIONS ! - IF (KK /= 2) RETURN - X1 = P(1,I)*RR(1) - X2 = P(2,I)*RR(2) - P2(1) = X1/C - P2(2) = X2/C - DO J = 3, NO - X3 = P(J,I)*RR(J) - XX(J-1) = (D10*X2 + X1 + X3)*CH - X1 = X2 - X2 = X3 - END DO - CALL NMRVS (NJ, DEL2, M2, P2, XX) - AA = -DEL2/DELH - M = MAX0(M,M2) - P2(:NO) = P2(:NO) + AA*HQ(:NO) - A11 = QUAD(I,M,P2,P2) - B11 = QUAD(I,M,PDE,P2) - C11 = QUAD(I,M,PDE,PDE) - D1 - DISC = B11*B11 - A11*C11 - IF (DISC >= D0) THEN - DE1 = -(B11 + DSQRT(DISC))/A11 - DE2 = C11/A11/DE1 - IF (PDE(3) + DE1*P2(3) < D0) DE1 = DE2 - ELSE - DE1 = C11/A11 - ENDIF - PDE(:NO) = PDE(:NO) + DE1*P2(:NO) - PP = PP + DE1*AA - RETURN - END SUBROUTINE SOLVE + IF (KK /= 2) RETURN + X1 = P(1,I)*RR(1) + X2 = P(2,I)*RR(2) + P2(1) = X1/C + P2(2) = X2/C + DO J = 3, NO + X3 = P(J,I)*RR(J) + XX(J-1) = (D10*X2 + X1 + X3)*CH + X1 = X2 + X2 = X3 + END DO + CALL NMRVS (NJ, DEL2, M2, P2, XX) + AA = -DEL2/DELH + M = MAX0(M,M2) + P2(:NO) = P2(:NO) + AA*HQ(:NO) + A11 = QUAD(I,M,P2,P2) + B11 = QUAD(I,M,PDE,P2) + C11 = QUAD(I,M,PDE,PDE) - D1 + DISC = B11*B11 - A11*C11 + IF (DISC >= D0) THEN + DE1 = -(B11 + DSQRT(DISC))/A11 + DE2 = C11/A11/DE1 + IF (PDE(3) + DE1*P2(3) < D0) DE1 = DE2 + ELSE + DE1 = C11/A11 + ENDIF + PDE(:NO) = PDE(:NO) + DE1*P2(:NO) + PP = PP + DE1*AA + RETURN + END SUBROUTINE SOLVE ! ! ------------------------------------------------------------------ ! S U M M R Y @@ -5220,86 +5220,86 @@ END SUBROUTINE SOLVE ! RELATIVISTIC SHIFT (EREL) FOR THE STATE ! TOTAL ENERGY (ET) ! - SUBROUTINE SUMMRY(ET, EREL) + SUBROUTINE SUMMRY(ET, EREL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE INOUT_C - USE LABEL_C - USE RADIAL_C, ONLY: AZ, L, N, NOD - USE WAVE_C, ONLY: EK, E, SUM, S - USE PARAM_C - USE COEFF_C + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE INOUT_C + USE LABEL_C + USE RADIAL_C, ONLY: AZ, L, N, NOD + USE WAVE_C, ONLY: EK, E, SUM, S + USE PARAM_C + USE COEFF_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quadr_I - USE hl_I - USE rlshft_I + USE quadr_I + USE hl_I + USE rlshft_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: ET - REAL(DOUBLE) , INTENT(IN) :: EREL + REAL(DOUBLE) , INTENT(IN) :: ET + REAL(DOUBLE) , INTENT(IN) :: EREL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I REAL(DOUBLE) :: PI, EN, EKINP, RH, SC, RELS, RM3, RP2, RZ, ETN, EPOTL, & - RATIO + RATIO REAL(DOUBLE), DIMENSION(NWFD) :: R1, RM1 !----------------------------------------------- ! - PI = ACOS((-D1)) - WRITE (3, 9) ATOM, TERM + PI = ACOS((-D1)) + WRITE (3, 9) ATOM, TERM 9 FORMAT(/,/,/,24X,'ATOM ',A6,3X,'TERM ',A6,/,/,2X,'nl',7X,'E(nl)',8X,& - 'I(nl)',7X,'KE(nl)',8X,'Rel(nl)',3X,'S(nl)',7X,'Az(nl)') - EN = D0 - REL = .FALSE. + 'I(nl)',7X,'KE(nl)',8X,'Rel(nl)',3X,'S(nl)',7X,'Az(nl)') + EN = D0 + REL = .FALSE. ! ! ***** COMPUTE AND PRINT ONE-ELECTRON PARAMETERS ! - DO I = 1, NWF - R1(I) = QUADR(I,I,1) - EK(I) = -D5*HL(EL,I,I,REL) - RM1(I) = QUADR(I,I,-1) - EKINP = EK(I) + Z*RM1(I) - EN = EN + SUM(I)*EKINP - RH = 3*N(I)*N(I) - L(I)*(L(I)+1) - SC = Z - D5*RH/R1(I) - S(I) = SC - RELS = RLSHFT(I,I) - WRITE (3, 15) EL(I), E(I,I), EK(I), EKINP, RELS, S(I), AZ(I) - 15 FORMAT(1X,A3,F14.7,3F13.6,F8.3,F14.6) - END DO + DO I = 1, NWF + R1(I) = QUADR(I,I,1) + EK(I) = -D5*HL(EL,I,I,REL) + RM1(I) = QUADR(I,I,-1) + EKINP = EK(I) + Z*RM1(I) + EN = EN + SUM(I)*EKINP + RH = 3*N(I)*N(I) - L(I)*(L(I)+1) + SC = Z - D5*RH/R1(I) + S(I) = SC + RELS = RLSHFT(I,I) + WRITE (3, 15) EL(I), E(I,I), EK(I), EKINP, RELS, S(I), AZ(I) + 15 FORMAT(1X,A3,F14.7,3F13.6,F8.3,F14.6) + END DO ! ! ***** Compute Moments ! - WRITE (3, 8) 'Delta(R)' - 8 FORMAT(/,/,2X,'nl',6X,A8,5X,'1/R**3',7X,'1/R',9X,'R',8X,'R**2') - DO I = 1, NWF - RM3 = 0 - IF (L(I) /= 0) RM3 = QUADR(I,I,-3) - RP2 = QUADR(I,I,2) - RZ = 0. - IF (L(I) == 0) RZ = AZ(I)**2/(4.*PI) - WRITE (3, 16) EL(I), RZ, RM3, RM1(I), R1(I), RP2 - 16 FORMAT(1X,A3,F14.3,F13.4,F11.5,F10.5,F11.5) - END DO - ETN = ET - EREL - EPOTL = ETN - EN - RATIO = EPOTL/EN - WRITE (0, 26) ETN, EN, EREL, EPOTL, ET, RATIO - WRITE (3, 26) ETN, EN, EREL, EPOTL, ET, RATIO + WRITE (3, 8) 'Delta(R)' + 8 FORMAT(/,/,2X,'nl',6X,A8,5X,'1/R**3',7X,'1/R',9X,'R',8X,'R**2') + DO I = 1, NWF + RM3 = 0 + IF (L(I) /= 0) RM3 = QUADR(I,I,-3) + RP2 = QUADR(I,I,2) + RZ = 0. + IF (L(I) == 0) RZ = AZ(I)**2/(4.*PI) + WRITE (3, 16) EL(I), RZ, RM3, RM1(I), R1(I), RP2 + 16 FORMAT(1X,A3,F14.3,F13.4,F11.5,F10.5,F11.5) + END DO + ETN = ET - EREL + EPOTL = ETN - EN + RATIO = EPOTL/EN + WRITE (0, 26) ETN, EN, EREL, EPOTL, ET, RATIO + WRITE (3, 26) ETN, EN, EREL, EPOTL, ET, RATIO 26 FORMAT(/,/,5X,'TOTAL ENERGY (a.u.)'/,5X,'----- ------'/,10X,& ' Non-Relativistic ',F15.8,T50,'Kinetic ',F15.8,/,10X,& ' Relativistic Shift ',F15.8,T50,'Potential ',F15.8,/,10X,& - ' Relativistic ',F15.8,T50,'Ratio ',F15.9) - RETURN - END SUBROUTINE SUMMRY + ' Relativistic ',F15.8,T50,'Ratio ',F15.9) + RETURN + END SUBROUTINE SUMMRY ! ! ------------------------------------------------------------------ ! V @@ -5308,33 +5308,33 @@ END SUBROUTINE SUMMRY ! k ! Evaluates V (i,j) as defined by Blume and Watson (1962). ! - REAL(KIND(0.0D0)) FUNCTION VK (I, J, II, JJ, K) + REAL(KIND(0.0D0)) FUNCTION VK (I, J, II, JJ, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dyk_I - USE quads_I + USE dyk_I + USE quads_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER :: II - INTEGER :: JJ - INTEGER :: K + INTEGER :: I + INTEGER :: J + INTEGER :: II + INTEGER :: JJ + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - CALL DYK (I, II, K) - VK = QUADS(J,JJ,2)*FINE - RETURN - END FUNCTION VK + CALL DYK (I, II, K) + VK = QUADS(J,JJ,2)*FINE + RETURN + END FUNCTION VK ! ! ------------------------------------------------------------------ ! W A V E F N @@ -5352,157 +5352,157 @@ END FUNCTION VK ! The set of functions are then orthogonalized. ! ! - SUBROUTINE WAVEFN + SUBROUTINE WAVEFN !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE INOUT_C - USE PARAM_C - USE TEST_C - USE RADIAL_C - USE WAVE_C, ONLY: EK, E, S - USE LABEL_C, ONLY: EL - USE COEFF_C + USE vast_kind_param, ONLY: DOUBLE + USE INOUT_C + USE PARAM_C + USE TEST_C + USE RADIAL_C + USE WAVE_C, ONLY: EK, E, S + USE LABEL_C, ONLY: EL + USE COEFF_C USE ESTP_C, ONLY: ZZ, IND !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE eptr_I - USE hnorm_I - USE hwf_I - USE quadr_I + USE eptr_I + USE hnorm_I + USE hwf_I + USE quadr_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1, I, J, IM, II, M, K, MT - REAL(DOUBLE) :: C, PNN, PN, Z2, FN, ZT, ETI, EKI, AZI + INTEGER :: J1, I, J, IM, II, M, K, MT + REAL(DOUBLE) :: C, PNN, PN, Z2, FN, ZT, ETI, EKI, AZI REAL(DOUBLE) :: PT(NOD) - CHARACTER :: EL1*3, AT*6, TT*6 - CHARACTER , DIMENSION(NWFD) :: ATM*6, TRM*6 - CHARACTER :: TITLE*24 + CHARACTER :: EL1*3, AT*6, TT*6 + CHARACTER , DIMENSION(NWFD) :: ATM*6, TRM*6 + CHARACTER :: TITLE*24 !----------------------------------------------- ! ! ***** GENERATE ARRAYS FOR R,R*R AND SQRT(R) WITH A CONSTANT MESH ! ***** SIZE IN THE LOG(Z*R) VARIABLE ! - DO I = 1, NO - R(I) = DEXP(RHO)/Z - RR(I) = R(I)*R(I) - R2(I) = DSQRT(R(I)) - RHO = RHO + H - END DO - RHO = RHO - NO*H + DO I = 1, NO + R(I) = DEXP(RHO)/Z + RR(I) = R(I)*R(I) + R2(I) = DSQRT(R(I)) + RHO = RHO + H + END DO + RHO = RHO - NO*H ! ! ***** READ THE WAVEFUNCTIONS ! - IF (IUF /= 0) THEN -! 2 CONTINUE - 2 READ (IUF, END=5) AT, TT, EL1, M, ZT, ETI, EKI, AZI, (PT(J),J=1,M) - CALL EPTR (EL, EL1, I, J1) - IF (J1 == 1) GO TO 2 - IF (I>0 .AND. IND(I)==(-1)) THEN - ATM(I) = AT - TRM(I) = TT - MAX(I) = M - ZZ(I) = ZT - C = D1 - IF (Z /= ZT) C = Z/ZT + IF (IUF /= 0) THEN +! 2 CONTINUE + 2 READ (IUF, END=5) AT, TT, EL1, M, ZT, ETI, EKI, AZI, (PT(J),J=1,M) + CALL EPTR (EL, EL1, I, J1) + IF (J1 == 1) GO TO 2 + IF (I>0 .AND. IND(I)==(-1)) THEN + ATM(I) = AT + TRM(I) = TT + MAX(I) = M + ZZ(I) = ZT + C = D1 + IF (Z /= ZT) C = Z/ZT ! ! ***** SCALE RESULTS IF CARDS ARE FOR AN ATOM WITH A DIFFERENT Z ! - E(I,I) = C*C*ETI - EK(I) = C*C*EKI - AZ(I) = AZI*C**(L(I)+1)*DSQRT(C) - P(:M,I) = C*PT(:M) + E(I,I) = C*C*ETI + EK(I) = C*C*EKI + AZ(I) = AZI*C**(L(I)+1)*DSQRT(C) + P(:M,I) = C*PT(:M) ! ! ***** SET REMAINING VALUES IN THE RANGE = 0. ! - IF (M /= NO) THEN - M = M + 1 - P(M:NO,I) = D0 - ENDIF - IND(I) = -2 - ENDIF - GO TO 2 + IF (M /= NO) THEN + M = M + 1 + P(M:NO,I) = D0 + ENDIF + IND(I) = -2 + ENDIF + GO TO 2 ! ! ***** SET PARAMTERS FOR ELECTRONS AND INITIALIZE FUNCTIONS ! - ENDIF - 5 CONTINUE - DO I = 1, NWF - IF (IND(I) > 0) CYCLE - IF (IND(I) /= 0) THEN - IF (IND(I) == (-2)) GO TO 4 - IND(I) = 0 - WRITE (6, 27) EL(I) - 27 FORMAT(8X,'WAVE FUNCTIONS NOT FOUND FOR ',A3) - ENDIF + ENDIF + 5 CONTINUE + DO I = 1, NWF + IF (IND(I) > 0) CYCLE + IF (IND(I) /= 0) THEN + IF (IND(I) == (-2)) GO TO 4 + IND(I) = 0 + WRITE (6, 27) EL(I) + 27 FORMAT(8X,'WAVE FUNCTIONS NOT FOUND FOR ',A3) + ENDIF ! ! ***** DETERMINE ESTIMATES OF THE WAVE FUNCTIONS BY THE SCREENED ! ***** HYDROGENIC APPROXIMATION ! - IF (Z - S(I) > D0) THEN - PN = HNORM(N(I),L(I),Z-S(I)) - ELSE - WRITE (0, '(A,A)') ' Effective nuclear charge zero for ', EL(I) - STOP - ENDIF - DO J = 1, NO - P(J,I) = PN*HWF(N(I),L(I),Z-S(I),R(J))/R2(J) - END DO - - M = NO - 30 CONTINUE - IF (DABS(P(M,I)) > 1.D-15) GO TO 31 - P(M,I) = D0 - M = M - 1 - GO TO 30 - 31 CONTINUE - MAX(I) = M + IF (Z - S(I) > D0) THEN + PN = HNORM(N(I),L(I),Z-S(I)) + ELSE + WRITE (0, '(A,A)') ' Effective nuclear charge zero for ', EL(I) + STOP + ENDIF + DO J = 1, NO + P(J,I) = PN*HWF(N(I),L(I),Z-S(I),R(J))/R2(J) + END DO + + M = NO + 30 CONTINUE + IF (DABS(P(M,I)) > 1.D-15) GO TO 31 + P(M,I) = D0 + M = M - 1 + GO TO 30 + 31 CONTINUE + MAX(I) = M ! ! ***** SET THE AZ(I) VALUE ! - AZ(I) = PN*(D2*(Z - D5*S(I))/N(I))**(L(I)+1) + AZ(I) = PN*(D2*(Z - D5*S(I))/N(I))**(L(I)+1) ! ! ***** ORTHOGONALIZE TO INNER FUNCTIONS ! - 4 CONTINUE - IF (I == 1) CYCLE - IM = I - 1 - DO II = 1, IM - IF (E(I,II) == D0) CYCLE - PN = QUADR(I,II,0) - IF (DABS(PN) <= 1.D-8) CYCLE - PNN = DSQRT(D1 - PN*PN) - IF (P(50,I) - PN*P(50,II) < D0) PNN = -PNN - M = MAX0(MAX(I),MAX(II)) - P(:M,I) = (P(:M,I)-PN*P(:M,II))/PNN - END DO - END DO - WRITE (3, 14) + 4 CONTINUE + IF (I == 1) CYCLE + IM = I - 1 + DO II = 1, IM + IF (E(I,II) == D0) CYCLE + PN = QUADR(I,II,0) + IF (DABS(PN) <= 1.D-8) CYCLE + PNN = DSQRT(D1 - PN*PN) + IF (P(50,I) - PN*P(50,II) < D0) PNN = -PNN + M = MAX0(MAX(I),MAX(II)) + P(:M,I) = (P(:M,I)-PN*P(:M,II))/PNN + END DO + END DO + WRITE (3, 14) 14 FORMAT(/,/,/,8X,'INITIAL ESTIMATES '/,/,10X,'NL',4X,'SIGMA',6X,'E(NL)',4X& - ,'AZ(NL)',4X,'FUNCTIONS'/,/) + ,'AZ(NL)',4X,'FUNCTIONS'/,/) ! ! ***** COMPUTE ONE-ELECTRON ENERGY PARAMETERS IF THEY WERE NOT ! ***** SPECIFIED ON INPUT. ! - DO I = 1, NWF - K = IND(I) + 2 - IF (IND(I) == (-2)) THEN - TITLE = ' SCALED '//ATM(I)//TRM(I) - ELSE IF (IND(I) == 0) THEN - TITLE = ' SCREENED HYDROGENIC' - ELSE - TITLE = ' UNCHANGED' - ENDIF - WRITE (3, 19) EL(I), S(I), E(I,I), AZ(I), TITLE - WRITE (6, 19) EL(I), S(I), E(I,I), AZ(I), TITLE - 19 FORMAT(9X,A3,F9.2,F11.3,F10.3,3X,A24) - END DO - RETURN - END SUBROUTINE WAVEFN + DO I = 1, NWF + K = IND(I) + 2 + IF (IND(I) == (-2)) THEN + TITLE = ' SCALED '//ATM(I)//TRM(I) + ELSE IF (IND(I) == 0) THEN + TITLE = ' SCREENED HYDROGENIC' + ELSE + TITLE = ' UNCHANGED' + ENDIF + WRITE (3, 19) EL(I), S(I), E(I,I), AZ(I), TITLE + WRITE (6, 19) EL(I), S(I), E(I,I), AZ(I), TITLE + 19 FORMAT(9X,A3,F9.2,F11.3,F10.3,3X,A24) + END DO + RETURN + END SUBROUTINE WAVEFN ! ! ------------------------------------------------------------------ ! X C H @@ -5520,61 +5520,61 @@ END SUBROUTINE WAVEFN ! 3 r SQRT(r) ( X(r) + SUM e P ) ! ij j ! - SUBROUTINE XCH(I, IOPT) + SUBROUTINE XCH(I, IOPT) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE TEST_C - USE PARAM_C - USE WAVE_C - USE RADIAL_C, ONLY: R, RR, P, YK, X, L + USE vast_kind_param, ONLY: DOUBLE + USE TEST_C + USE PARAM_C + USE WAVE_C + USE RADIAL_C, ONLY: R, RR, P, YK, X, L !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE b_I - USE ykf_I + USE b_I + USE ykf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER , INTENT(IN) :: IOPT + INTEGER :: I + INTEGER , INTENT(IN) :: IOPT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, K, JJ - REAL(DOUBLE) :: C -!----------------------------------------------- - X(:NO) = D0 - DO J = 1, NWF - IF (J == I) CYCLE - DO K = IABS(L(I)-L(J)), L(I) + L(J), 2 - C = B(I,J,K)*D2 - IF (DABS(C) <= 1.D-10) CYCLE - CALL YKF (I, J, K, REL) - X(:NO) = X(:NO) + C*YK(:NO)*P(:NO,J) - END DO - END DO - GO TO (75,76,77) IOPT - 76 CONTINUE - X(:NO) = X(:NO)/R(:NO) - GO TO 75 - 77 CONTINUE - X(:NO) = R(:NO)*X(:NO) - DO J = 1, NWF - C = E(I,J) - IF (DABS(C)<=1.D-10 .OR. J==I) CYCLE - X(:NO) = X(:NO) + C*P(:NO,J)*RR(:NO) - END DO + INTEGER :: J, K, JJ + REAL(DOUBLE) :: C +!----------------------------------------------- + X(:NO) = D0 + DO J = 1, NWF + IF (J == I) CYCLE + DO K = IABS(L(I)-L(J)), L(I) + L(J), 2 + C = B(I,J,K)*D2 + IF (DABS(C) <= 1.D-10) CYCLE + CALL YKF (I, J, K, REL) + X(:NO) = X(:NO) + C*YK(:NO)*P(:NO,J) + END DO + END DO + GO TO (75,76,77) IOPT + 76 CONTINUE + X(:NO) = X(:NO)/R(:NO) + GO TO 75 + 77 CONTINUE + X(:NO) = R(:NO)*X(:NO) + DO J = 1, NWF + C = E(I,J) + IF (DABS(C)<=1.D-10 .OR. J==I) CYCLE + X(:NO) = X(:NO) + C*P(:NO,J)*RR(:NO) + END DO ! ! ***** CHECK IF EXCHANGE IS ZERO: IF SO, METHOD 2 SHOULD BE USED. ! - 75 CONTINUE - IF (METH(I) == 2) RETURN - IF (DABS(X(1)) + DABS(X(2)) + DABS(X(3)) == D0) METH(I) = 2 - RETURN - END SUBROUTINE XCH + 75 CONTINUE + IF (METH(I) == 2) RETURN + IF (DABS(X(1)) + DABS(X(2)) + DABS(X(3)) == D0) METH(I) = 2 + RETURN + END SUBROUTINE XCH ! ! ------------------------------------------------------------------ ! Y K F @@ -5584,57 +5584,57 @@ END SUBROUTINE XCH ! Stores Y (i, j; r) in the array YK ! ! - SUBROUTINE YKF(I, J, K, REL) + SUBROUTINE YKF(I, J, K, REL) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE zk_I + USE zk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J, K - LOGICAL , INTENT(IN) :: REL + INTEGER :: I, J, K + LOGICAL , INTENT(IN) :: REL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MX, M - REAL(DOUBLE) :: A, C, A2, H90, A3, AI, AN, A34, F1, F2, F3, F4, F5 -!----------------------------------------------- - CALL ZK (I, J, K) - A = EH**(K + 1) - C = 2*K + 1 - A2 = A*A - H90 = C*H3/D30 - A3 = A2*A*H90 - AI = H90/A - AN = 114.D0*A*H90 - A34 = 34.D0*H90 - MX = (MIN0(MAX(I),MAX(J))/2)*2 - F1 = YK(MX)*EH**K - F2 = YK(MX) - F3 = YK(MX-1) - F4 = YK(MX-2) - DO M = MX - 2, 2, -1 - F5 = YK(M-1) - YK(M) = YK(M+2)*A2 + (AN*F3 + A34*(F4 + A2*F2) - F5*AI - F1*A3) - F1 = F2 - F2 = F3 - F3 = F4 - F4 = F5 - END DO - YK(1) = YK(3)*A2 + C*H3*(F4 + D4*A*F3 + A2*F2) - IF (.NOT.REL) RETURN - C = C*FINE - YK(:MX) = YK(:MX) + C*P(:MX,I)*P(:MX,J) - RETURN - END SUBROUTINE YKF + INTEGER :: MX, M + REAL(DOUBLE) :: A, C, A2, H90, A3, AI, AN, A34, F1, F2, F3, F4, F5 +!----------------------------------------------- + CALL ZK (I, J, K) + A = EH**(K + 1) + C = 2*K + 1 + A2 = A*A + H90 = C*H3/D30 + A3 = A2*A*H90 + AI = H90/A + AN = 114.D0*A*H90 + A34 = 34.D0*H90 + MX = (MIN0(MAX(I),MAX(J))/2)*2 + F1 = YK(MX)*EH**K + F2 = YK(MX) + F3 = YK(MX-1) + F4 = YK(MX-2) + DO M = MX - 2, 2, -1 + F5 = YK(M-1) + YK(M) = YK(M+2)*A2 + (AN*F3 + A34*(F4 + A2*F2) - F5*AI - F1*A3) + F1 = F2 + F2 = F3 + F3 = F4 + F4 = F5 + END DO + YK(1) = YK(3)*A2 + C*H3*(F4 + D4*A*F3 + A2*F2) + IF (.NOT.REL) RETURN + C = C*FINE + YK(:MX) = YK(:MX) + C*P(:MX,I)*P(:MX,J) + RETURN + END SUBROUTINE YKF ! ! ------------------------------------------------------------------ ! Z K @@ -5644,64 +5644,64 @@ END SUBROUTINE YKF ! Stores Z (i, j; r) in the array YK. ! ! - SUBROUTINE ZK(I, J, K) + SUBROUTINE ZK(I, J, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE PARAM_C - USE RADIAL_C + USE vast_kind_param, ONLY: DOUBLE + USE PARAM_C + USE RADIAL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I, J, K + INTEGER , INTENT(IN) :: I, J, K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MX, M, M1, M2 + INTEGER :: MX, M, M1, M2 REAL(DOUBLE) :: DEN, FACT, A, A2, H90, A3, AI, AN, A34, F1, F2, F3, F4, & - F5, C1, C2 -!----------------------------------------------- - DEN = L(I) + L(J) + 3 + K - FACT = (D1/(L(I)+1)+D1/(L(J)+1))/(DEN + D1) - A = EH**K - A2 = A*A - H90 = H/90.D0 - A3 = A2*A*H90 - AI = H90/A - AN = 114.D0*A*H90 - A34 = 34.D0*H90 - F1 = RR(1)*P(1,I)*P(1,J) - F2 = RR(2)*P(2,I)*P(2,J) - F3 = RR(3)*P(3,I)*P(3,J) - F4 = RR(4)*P(4,I)*P(4,J) - YK(1) = F1*(D1 + Z*R(1)*FACT)/DEN - YK(2) = F2*(D1 + Z*R(2)*FACT)/DEN - YK(3) = YK(1)*A2 + H3*(F3 + D4*A*F2 + A2*F1) - MX = (MIN0(MAX(I),MAX(J))/2)*2 - DO M = 5, MX - F5 = (RR(M)*P(M,I))*P(M,J) - YK(M-1) = YK(M-3)*A2 + (AN*F3 + A34*(F4 + A2*F2) - F5*AI - F1*A3) - F1 = F2 - F2 = F3 - F3 = F4 - F4 = F5 - END DO - M1 = MX - 1 - IF (IABS(I - J) + IABS(K) == 0) THEN + F5, C1, C2 +!----------------------------------------------- + DEN = L(I) + L(J) + 3 + K + FACT = (D1/(L(I)+1)+D1/(L(J)+1))/(DEN + D1) + A = EH**K + A2 = A*A + H90 = H/90.D0 + A3 = A2*A*H90 + AI = H90/A + AN = 114.D0*A*H90 + A34 = 34.D0*H90 + F1 = RR(1)*P(1,I)*P(1,J) + F2 = RR(2)*P(2,I)*P(2,J) + F3 = RR(3)*P(3,I)*P(3,J) + F4 = RR(4)*P(4,I)*P(4,J) + YK(1) = F1*(D1 + Z*R(1)*FACT)/DEN + YK(2) = F2*(D1 + Z*R(2)*FACT)/DEN + YK(3) = YK(1)*A2 + H3*(F3 + D4*A*F2 + A2*F1) + MX = (MIN0(MAX(I),MAX(J))/2)*2 + DO M = 5, MX + F5 = (RR(M)*P(M,I))*P(M,J) + YK(M-1) = YK(M-3)*A2 + (AN*F3 + A34*(F4 + A2*F2) - F5*AI - F1*A3) + F1 = F2 + F2 = F3 + F3 = F4 + F4 = F5 + END DO + M1 = MX - 1 + IF (IABS(I - J) + IABS(K) == 0) THEN ! ! ***** FOR Y0(I,I) SET THE LIMIT TO 1 AND REMOVE OSCILLATIONS ! ***** INTRODUCED BY THE USE OF SIMPSON'S RULE ! - M2 = M1 - 1 - C1 = D1 - YK(M1) - C2 = D1 - YK(M2) - YK(:M1:2) = YK(:M1:2) + C1 - YK(2:M1+1:2) = YK(2:M1+1:2) + C2 - ENDIF - DO M = M1 + 1, NO - YK(M) = A*YK(M-1) - END DO - RETURN - END SUBROUTINE ZK + M2 = M1 - 1 + C1 = D1 - YK(M1) + C2 = D1 - YK(M2) + YK(:M1:2) = YK(:M1:2) + C1 + YK(2:M1+1:2) = YK(2:M1+1:2) + C2 + ENDIF + DO M = M1 + 1, NO + YK(M) = A*YK(M-1) + END DO + RETURN + END SUBROUTINE ZK diff --git a/src/appl/HF/Makefile b/src/appl/HF/Makefile old mode 100755 new mode 100644 index 0b83c12e5..a472b7523 --- a/src/appl/HF/Makefile +++ b/src/appl/HF/Makefile @@ -4,9 +4,9 @@ BIN = ${GRASP}/bin UTIL = hf -install: EXE +install: EXE -EXE : $(BIN)/hf +EXE : $(BIN)/hf OBJ : hf .o @@ -18,6 +18,3 @@ $(BIN)/hf: HF.o clean: -rm -f *.o core *.mod - - - diff --git a/src/appl/Makefile b/src/appl/Makefile old mode 100755 new mode 100644 index 36ee6506d..019667fa7 --- a/src/appl/Makefile +++ b/src/appl/Makefile @@ -22,4 +22,3 @@ clean : make clean; \ cd .. ; \ done - diff --git a/src/appl/jj2lsj90/Makefile b/src/appl/jj2lsj90/Makefile old mode 100755 new mode 100644 index 766b654fb..fc464ef04 --- a/src/appl/jj2lsj90/Makefile +++ b/src/appl/jj2lsj90/Makefile @@ -23,11 +23,11 @@ Commons = jj2lsj_data_1_C.o jj2lsj_data_2_C.o jj2lsj_data_3_C.o Memory = ${MODDIR}/memory_man.o # Define interface to routines from the library -Interface = packLS_I.o getmixblock_I.o idigit_I.o lval_I.o +Interface = packLS_I.o getmixblock_I.o idigit_I.o lval_I.o APP_OBJ = \ packLS.o getmixblock.o idigit.o lval.o \ - jj2lsj_code.o jj2lsj2K.o + jj2lsj_code.o jj2lsj2K.o $(EXE): ${VASTO} ${Commons} ${Memory} ${Interface} $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(Commons) ${Interface} $(APP_OBJ) $(APP_LIBS) diff --git a/src/appl/jj2lsj90/getmixblock.f90 b/src/appl/jj2lsj90/getmixblock.f90 index c4e9c455c..1988d08aa 100644 --- a/src/appl/jj2lsj90/getmixblock.f90 +++ b/src/appl/jj2lsj90/getmixblock.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETMIXBLOCK(NAME, NCI) + SUBROUTINE GETMIXBLOCK(NAME, NCI) ! * ! Reads mixing coefficient file from block-structured format * ! * @@ -14,13 +14,13 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man USE def_C - USE EIGV_C + USE EIGV_C USE orb_C USE prnt_C USE syma_C @@ -29,78 +29,78 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NCI - CHARACTER(LEN=24), INTENT(IN) :: NAME + INTEGER , INTENT(IN) :: NCI + CHARACTER(LEN=24), INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: K, IERR, IOS, NCFTOT, NVECTOT, NVECSIZ, NBLOCK, I, NVECPAT, & - NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J - REAL(DOUBLE) :: EAVSUM - CHARACTER(LEN=3) :: STATUS - CHARACTER(LEN=6) :: G92MIX - CHARACTER(LEN=11) :: FORM - CHARACTER(LEN=256) :: FILNAM + NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J + REAL(DOUBLE) :: EAVSUM + CHARACTER(LEN=3) :: STATUS + CHARACTER(LEN=6) :: G92MIX + CHARACTER(LEN=11) :: FORM + CHARACTER(LEN=256) :: FILNAM !----------------------------------------------- ! ! The .mix file is UNFORMATTED; it must exist ! - K = INDEX(NAME,' ') - IF (NCI == 0) THEN - FILNAM = NAME(1:K-1)//'.cm' - ELSE - FILNAM = NAME(1:K-1)//'.m' - ENDIF - FORM = 'UNFORMATTED' - STATUS = 'OLD' + K = INDEX(NAME,' ') + IF (NCI == 0) THEN + FILNAM = NAME(1:K-1)//'.cm' + ELSE + FILNAM = NAME(1:K-1)//'.m' + ENDIF + FORM = 'UNFORMATTED' + STATUS = 'OLD' ! - CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (ISTDE, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (ISTDE, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the header of the file; if not as expected, try again ! - READ (25, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' - CLOSE(25) - STOP - ENDIF - - READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - WRITE (*, *) ' nelec = ', NELEC - WRITE (*, *) ' ncftot = ', NCFTOT - WRITE (*, *) ' nw = ', NW - WRITE (*, *) ' nblock = ', NBLOCK - WRITE (*, *) - + READ (25, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' + CLOSE(25) + STOP + ENDIF + + READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + WRITE (*, *) ' nelec = ', NELEC + WRITE (*, *) ' ncftot = ', NCFTOT + WRITE (*, *) ' nw = ', NW + WRITE (*, *) ' nblock = ', NBLOCK + WRITE (*, *) + !*********************************************************************** ! Allocate memory for old format data !*********************************************************************** - -!GG CALL ALLOC (EVAL, NVECTOT, 'EVAL', 'GETMIXBLOCK') -!GG CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', 'GETMIXBLOCK') -!GG CALL ALLOC (IVEC, NVECTOT, 'IVEC', 'GETMIXBLOCK') -!GG CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', 'GETMIXBLOCK') -!GG CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', 'GETMIXBLOCK') - allocate (EVAL(NVECTOT)) - allocate (EVEC(NCFTOT*NVECTOT)) - allocate (IVEC(NVECTOT)) - allocate (IATJPO(NVECTOT)) - allocate (IASPAR(NVECTOT)) - + +!GG CALL ALLOC (EVAL, NVECTOT, 'EVAL', 'GETMIXBLOCK') +!GG CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', 'GETMIXBLOCK') +!GG CALL ALLOC (IVEC, NVECTOT, 'IVEC', 'GETMIXBLOCK') +!GG CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', 'GETMIXBLOCK') +!GG CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', 'GETMIXBLOCK') + allocate (EVAL(NVECTOT)) + allocate (EVEC(NCFTOT*NVECTOT)) + allocate (IVEC(NVECTOT)) + allocate (IATJPO(NVECTOT)) + allocate (IASPAR(NVECTOT)) + !*********************************************************************** ! Initialize mixing coefficients to zero; others are fine !*********************************************************************** - EVEC(:NVECTOT*NCFTOT) = 0.D0 - + EVEC(:NVECTOT*NCFTOT) = 0.D0 + !*********************************************************************** ! Initialize counters and sum registers ! @@ -111,65 +111,65 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! at least one eigenstate is calculated ! neavsum: total number CSF contributing to eavsum !*********************************************************************** - - NVECPAT = 0 - NCFPAT = 0 - NVECSIZPAT = 0 - NEAVSUM = 0 - EAVSUM = 0.D0 - - WRITE (*, *) ' block ncf nev 2j+1 parity' - DO JB = 1, NBLOCK - - READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA - WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA + + NVECPAT = 0 + NCFPAT = 0 + NVECSIZPAT = 0 + NEAVSUM = 0 + EAVSUM = 0.D0 + + WRITE (*, *) ' block ncf nev 2j+1 parity' + DO JB = 1, NBLOCK + + READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA + WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA NEVINBLK(JB) = NEVBLK NCFINBLK(JB) = NCFBLK TWO_J(JB) = IATJP - 1 - IF (JB /= NB) STOP 'jb .NE. nb' - - IF (NEVBLK > 0) THEN - - READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) + IF (JB /= NB) STOP 'jb .NE. nb' + + IF (NEVBLK > 0) THEN + + READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) ! ivec(i) = ivec(i) + ncfpat ! serial # of the state - IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP - IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA - - READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) - + IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP + IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA + + READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) + ! ...Construct the true energy by adding up the average EVAL(NVECPAT+1:NEVBLK+NVECPAT) = EVAL(NVECPAT+1:NEVBLK+NVECPAT) + & - EAV + EAV ! ...For overal (all blocks) average energy - EAVSUM = EAVSUM + EAV*NCFBLK - NEAVSUM = NEAVSUM + NCFBLK - + EAVSUM = EAVSUM + EAV*NCFBLK + NEAVSUM = NEAVSUM + NCFBLK + READ (25) ((EVEC(NVECSIZPAT+NCFPAT+I+(J-1)*NCFTOT),I=1,NCFBLK),J=1,& - NEVBLK) - ENDIF -! - NVECPAT = NVECPAT + NEVBLK - NCFPAT = NCFPAT + NCFBLK - NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT -! - END DO - + NEVBLK) + ENDIF +! + NVECPAT = NVECPAT + NEVBLK + NCFPAT = NCFPAT + NCFBLK + NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT +! + END DO + ! ...Here eav is the average energy of the blocks where at least ! one eigenstate is calculated. It is not the averge of the ! total Hamiltonian. - - EAV = EAVSUM/NEAVSUM - + + EAV = EAVSUM/NEAVSUM + IF (NCFTOT /= NEAVSUM) WRITE (6, *) & - 'Not all blocks are diagonalized --- Average E ', 'not correct' - + 'Not all blocks are diagonalized --- Average E ', 'not correct' + ! ...Substrct the overal average energy - EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV -! - CLOSE(25) -! - NCF = NCFTOT - NVEC = NVECTOT -! - RETURN - END SUBROUTINE GETMIXBLOCK + EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV +! + CLOSE(25) +! + NCF = NCFTOT + NVEC = NVECTOT +! + RETURN + END SUBROUTINE GETMIXBLOCK diff --git a/src/appl/jj2lsj90/getmixblock_I.f90 b/src/appl/jj2lsj90/getmixblock_I.f90 index 01152da1d..4c56d861b 100644 --- a/src/appl/jj2lsj90/getmixblock_I.f90 +++ b/src/appl/jj2lsj90/getmixblock_I.f90 @@ -1,9 +1,9 @@ - MODULE getmixblock_I + MODULE getmixblock_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 - SUBROUTINE getmixblock (NAME, NCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCI - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 + SUBROUTINE getmixblock (NAME, NCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jj2lsj90/idigit.f90 b/src/appl/jj2lsj90/idigit.f90 index 665cfd979..0c73e2d61 100644 --- a/src/appl/jj2lsj90/idigit.f90 +++ b/src/appl/jj2lsj90/idigit.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION IDIGIT (CST) + INTEGER FUNCTION IDIGIT (CST) ! * ! * ! * @@ -10,21 +10,21 @@ INTEGER FUNCTION IDIGIT (CST) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: CST + CHARACTER , INTENT(IN) :: CST !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - CHARACTER, DIMENSION(0:9) :: CDGT + INTEGER :: I + CHARACTER, DIMENSION(0:9) :: CDGT !----------------------------------------------- ! - DATA CDGT/ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ + DATA CDGT/ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ ! - DO I = 0, 9 - IF (CST /= CDGT(I)) CYCLE + DO I = 0, 9 + IF (CST /= CDGT(I)) CYCLE IDIGIT = I EXIT - END DO + END DO ! - RETURN - END FUNCTION IDIGIT + RETURN + END FUNCTION IDIGIT diff --git a/src/appl/jj2lsj90/idigit_I.f90 b/src/appl/jj2lsj90/idigit_I.f90 index 2668fd24e..4f97636e8 100644 --- a/src/appl/jj2lsj90/idigit_I.f90 +++ b/src/appl/jj2lsj90/idigit_I.f90 @@ -1,8 +1,8 @@ - MODULE idigit_I + MODULE idigit_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 - INTEGER FUNCTION idigit (CST) - CHARACTER (LEN = 1), INTENT(IN) :: CST - END FUNCTION - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 + INTEGER FUNCTION idigit (CST) + CHARACTER (LEN = 1), INTENT(IN) :: CST + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/jj2lsj90/jj2lsj2K.f90 b/src/appl/jj2lsj90/jj2lsj2K.f90 index ca7c88c92..75943addd 100644 --- a/src/appl/jj2lsj90/jj2lsj2K.f90 +++ b/src/appl/jj2lsj90/jj2lsj2K.f90 @@ -23,7 +23,7 @@ PROGRAM jj2lsj2K ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE jj2lsj_code IMPLICIT NONE diff --git a/src/appl/jj2lsj90/jj2lsj_code.f90 b/src/appl/jj2lsj90/jj2lsj_code.f90 index adbe92c13..a8a495425 100644 --- a/src/appl/jj2lsj90/jj2lsj_code.f90 +++ b/src/appl/jj2lsj90/jj2lsj_code.f90 @@ -11,12 +11,12 @@ MODULE jj2lsj_code ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE implicit none !----------------------------------------------- -! R o u t i n e s +! R o u t i n e s !----------------------------------------------- public :: asf2ls ! Expands an atomic state function, which is represented @@ -25,7 +25,7 @@ MODULE jj2lsj_code ! Returns the value of the LS-jj transformation matrix ! for a given set of quantum numbers. private :: coefLSjj2 -! Returns the value of the LS-jj transformation matrix +! Returns the value of the LS-jj transformation matrix ! (l^2 LSJ| j_1 j_2 J). private :: coefLSjjs ! Returns the value of the LS-jj transformation matrix @@ -34,15 +34,15 @@ MODULE jj2lsj_code ! Dellocates the storage of asf_set_LS. public :: getchLS ! A spectroscopic notation of shell in LS coupling is return. - public :: getxj + public :: getxj ! public :: gettermLS -! This procedure return all allowed subshell terms -! (l, w, Q, L, S) for given l^N which must be 0, 1, 2 or 3. +! This procedure return all allowed subshell terms +! (l, w, Q, L, S) for given l^N which must be 0, 1, 2 or 3. public :: inscreen ! The input from the screen. public :: inscreenlev -! Attempts to interpret the serial level numbers from a +! Attempts to interpret the serial level numbers from a ! string. public :: jj2lsj ! Controls the transformation of atomic states from a jj- @@ -61,16 +61,16 @@ MODULE jj2lsj_code ! with data generated using the one from asf_set%csf_set ! ..................................................... ! This subroutine contains the following internal routines: -! * subroutine setLS_action -! The subroutine defines the "action" of subroutine +! * subroutine setLS_action +! The subroutine defines the "action" of subroutine ! setLS_job_count: whether it counts ! the number of csfs_LS (asf_set_LS%csf_set_LS%novcsf) ! or fills the arrays of wave functions in LS coupling ! with asf_set_LS%csf_set_LS%csf(...) with ! the corresponding quantum nubers. -! * subroutine setLS_add_quantum_numbers -! The subroutine adds quantum numbers stored -! in temprorary arrays Li, Si, L_i, S_i, w, Q to +! * subroutine setLS_add_quantum_numbers +! The subroutine adds quantum numbers stored +! in temprorary arrays Li, Si, L_i, S_i, w, Q to ! the corresponding arrays of asf_set_LS%csf_set_LS%csf(). ! private :: setLS_job_count ! * recursive subroutine setLS_job_count @@ -82,17 +82,17 @@ MODULE jj2lsj_code ! number of csfs_LS and corresponding quantum numbers. ! ..................................................... public :: traLSjj -! Return the value of the transformation matrix -! from jj- to LS-coupling scheme in the case of any +! Return the value of the transformation matrix +! from jj- to LS-coupling scheme in the case of any ! number of open shells. public :: traLSjjmp -! Return the value of main part of the transformation -! matrix from jj- to LS-coupling scheme in the +! Return the value of main part of the transformation +! matrix from jj- to LS-coupling scheme in the ! case of any number of open shells. private :: uniquelsj ! Subroutine defines a unique labels for energy levels !----------------------------------------------- -! D e f i n i t i o n o f A S F +! D e f i n i t i o n o f A S F ! i n L S - C o u p l i n g !----------------------------------------------- type, public :: nl @@ -181,7 +181,7 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE EIGV_C, ONLY: EVEC @@ -203,23 +203,23 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) !----------------------------------------------- integer, intent(in) :: iw1, levmax,IBLKNUM integer, intent(in) :: NCFMIN, NCFMAX - integer, dimension(:), intent(in) :: ithresh + integer, dimension(:), intent(in) :: ithresh integer, dimension(Blocks_number,Vectors_number), intent(in) :: levels !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- integer :: jj_number, lev, level, LS_number integer :: LOC, IMINCOMP - real(DOUBLE) :: wa_transformation - real(DOUBLE), dimension(Vectors_number) :: wa + real(DOUBLE) :: wa_transformation + real(DOUBLE), dimension(Vectors_number) :: wa real(DOUBLE), dimension(Vectors_number) :: wb !----------------------------------------------- wb = zero - do LS_number = 1, asf_set_LS%csf_set_LS%nocsf + do LS_number = 1, asf_set_LS%csf_set_LS%nocsf if ((asf_set_LS%csf_set_LS%csf(LS_number)%parity == "+" & .and. ISPAR(iw1) == 1) .or. & (asf_set_LS%csf_set_LS%csf(LS_number)%parity == "-" & - .and. ISPAR(iw1) == -1)) then + .and. ISPAR(iw1) == -1)) then wa = zero do jj_number = NCFMIN, NCFMAX if(ithresh(jj_number) == 1 .and. & @@ -243,8 +243,8 @@ SUBROUTINE asf2ls(iw1,ithresh,levmax,IBLKNUM,levels,NCFMIN,NCFMAX) end do if(IMINCOMPOFF == 1 ) THEN if(IMINCOMP == 1) GO TO 1 - end if - end if + end if + end if end do 1 continue return @@ -270,7 +270,7 @@ FUNCTION coefLSjj(l_shell,N,w,Q,L,S,J,jm_shell,Nm,Qm,Jm,jp_shell,& ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE @@ -353,7 +353,7 @@ FUNCTION coefLSjj2(l_shell,L,S,J,jm_shell,jp_shell) result(wa) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE @@ -414,7 +414,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE jj2lsj_C @@ -439,7 +439,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) select case(N) case(3) ! Use data from the array LS_jj_p_3 - do i = 1,LS_jj_number_p3 + do i = 1,LS_jj_number_p3 if(w ==LS_jj_p_3(i)%w .and. Q ==LS_jj_p_3(i)%Q .and. & L ==LS_jj_p_3(i)%L .and. S ==LS_jj_p_3(i)%S .and. & J ==LS_jj_p_3(i)%J .and. Nm ==LS_jj_p_3(i)%Nm .and. & @@ -452,7 +452,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(4) ! Use data from the array LS_jj_p_4 - do i = 1,LS_jj_number_p4 + do i = 1,LS_jj_number_p4 if(w ==LS_jj_p_4(i)%w .and. Q ==LS_jj_p_4(i)%Q .and. & L ==LS_jj_p_4(i)%L .and. S ==LS_jj_p_4(i)%S .and. & J ==LS_jj_p_4(i)%J .and. Nm ==LS_jj_p_4(i)%Nm .and. & @@ -465,7 +465,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(5) ! Use data from the array LS_jj_p_5 - do i = 1,LS_jj_number_p5 + do i = 1,LS_jj_number_p5 if(w ==LS_jj_p_5(i)%w .and. Q ==LS_jj_p_5(i)%Q .and. & L ==LS_jj_p_5(i)%L .and. S ==LS_jj_p_5(i)%S .and. & J ==LS_jj_p_5(i)%J .and. Nm ==LS_jj_p_5(i)%Nm .and. & @@ -478,7 +478,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(6) ! Use data from the array LS_jj_p_6 - do i = 1,LS_jj_number_p6 + do i = 1,LS_jj_number_p6 if(w ==LS_jj_p_6(i)%w .and. Q ==LS_jj_p_6(i)%Q .and. & L ==LS_jj_p_6(i)%L .and. S ==LS_jj_p_6(i)%S .and. & J ==LS_jj_p_6(i)%J .and. Nm ==LS_jj_p_6(i)%Nm .and. & @@ -496,7 +496,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) select case(N) case(3) ! Use data from the array LS_jj_d_3 - do i = 1,LS_jj_number_d3 + do i = 1,LS_jj_number_d3 if(w ==LS_jj_d_3(i)%w .and. Q ==LS_jj_d_3(i)%Q .and. & L ==LS_jj_d_3(i)%L .and. S ==LS_jj_d_3(i)%S .and. & J ==LS_jj_d_3(i)%J .and. Nm ==LS_jj_d_3(i)%Nm .and. & @@ -509,7 +509,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(4) ! Use data from the array LS_jj_d_4 - do i = 1,LS_jj_number_d4 + do i = 1,LS_jj_number_d4 if(w ==LS_jj_d_4(i)%w .and. Q ==LS_jj_d_4(i)%Q .and. & L ==LS_jj_d_4(i)%L .and. S ==LS_jj_d_4(i)%S .and. & J ==LS_jj_d_4(i)%J .and. Nm ==LS_jj_d_4(i)%Nm .and. & @@ -522,7 +522,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(5) ! Use data from the array LS_jj_d_5 - do i = 1,LS_jj_number_d5 + do i = 1,LS_jj_number_d5 if(w ==LS_jj_d_5(i)%w .and. Q ==LS_jj_d_5(i)%Q .and. & L ==LS_jj_d_5(i)%L .and. S ==LS_jj_d_5(i)%S .and. & J ==LS_jj_d_5(i)%J .and. Nm ==LS_jj_d_5(i)%Nm .and. & @@ -535,7 +535,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(6) ! Use data from the array LS_jj_d_6 - do i = 1,LS_jj_number_d6 + do i = 1,LS_jj_number_d6 if(w ==LS_jj_d_6(i)%w .and. Q ==LS_jj_d_6(i)%Q .and. & L ==LS_jj_d_6(i)%L .and. S ==LS_jj_d_6(i)%S .and. & J ==LS_jj_d_6(i)%J .and. Nm ==LS_jj_d_6(i)%Nm .and. & @@ -548,7 +548,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(7) ! Use data from the array LS_jj_d_7 - do i = 1,LS_jj_number_d7 + do i = 1,LS_jj_number_d7 if(w ==LS_jj_d_7(i)%w .and. Q ==LS_jj_d_7(i)%Q .and. & L ==LS_jj_d_7(i)%L .and. S ==LS_jj_d_7(i)%S .and. & J ==LS_jj_d_7(i)%J .and. Nm ==LS_jj_d_7(i)%Nm .and. & @@ -561,7 +561,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(8) ! Use data from the array LS_jj_d_8 - do i = 1,LS_jj_number_d8 + do i = 1,LS_jj_number_d8 if(w ==LS_jj_d_8(i)%w .and. Q ==LS_jj_d_8(i)%Q .and. & L ==LS_jj_d_8(i)%L .and. S ==LS_jj_d_8(i)%S .and. & J ==LS_jj_d_8(i)%J .and. Nm ==LS_jj_d_8(i)%Nm .and. & @@ -574,7 +574,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(9) ! Use data from the array LS_jj_d_9 - do i = 1,LS_jj_number_d9 + do i = 1,LS_jj_number_d9 if(w ==LS_jj_d_9(i)%w .and. Q ==LS_jj_d_9(i)%Q .and. & L ==LS_jj_d_9(i)%L .and. S ==LS_jj_d_9(i)%S .and. & J ==LS_jj_d_9(i)%J .and. Nm ==LS_jj_d_9(i)%Nm .and. & @@ -587,7 +587,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(10) ! Use data from the array LS_jj_d_10 - do i = 1,LS_jj_number_d10 + do i = 1,LS_jj_number_d10 if(w ==LS_jj_d_10(i)%w .and. Q ==LS_jj_d_10(i)%Q .and. & L ==LS_jj_d_10(i)%L .and. S ==LS_jj_d_10(i)%S .and. & J ==LS_jj_d_10(i)%J .and. Nm==LS_jj_d_10(i)%Nm .and. & @@ -605,7 +605,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) select case(N) case(3) ! Use data from the array LS_jj_f_3 - do i = 1,LS_jj_number_f3 + do i = 1,LS_jj_number_f3 if(w ==LS_jj_f_3(i)%w .and. Q ==LS_jj_f_3(i)%Q .and. & L ==LS_jj_f_3(i)%L .and. S ==LS_jj_f_3(i)%S .and. & J ==LS_jj_f_3(i)%J .and. Nm ==LS_jj_f_3(i)%Nm .and. & @@ -618,7 +618,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(4) ! Use data from the array LS_jj_f_4 - do i = 1,LS_jj_number_f4 + do i = 1,LS_jj_number_f4 if(w ==LS_jj_f_4(i)%w .and. Q ==LS_jj_f_4(i)%Q .and. & L ==LS_jj_f_4(i)%L .and. S ==LS_jj_f_4(i)%S .and. & J ==LS_jj_f_4(i)%J .and. Nm ==LS_jj_f_4(i)%Nm .and. & @@ -631,7 +631,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(5) ! Use data from the array LS_jj_f_5 - do i = 1,LS_jj_number_f5 + do i = 1,LS_jj_number_f5 if(w ==LS_jj_f_5(i)%w .and. Q ==LS_jj_f_5(i)%Q .and. & L ==LS_jj_f_5(i)%L .and. S ==LS_jj_f_5(i)%S .and. & J ==LS_jj_f_5(i)%J .and. Nm ==LS_jj_f_5(i)%Nm .and. & @@ -644,7 +644,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) end do case(6) ! Use data from the array LS_jj_f_6 - do i = 1,LS_jj_number_f6 + do i = 1,LS_jj_number_f6 if(w ==LS_jj_f_6(i)%w .and. Q ==LS_jj_f_6(i)%Q .and. & L ==LS_jj_f_6(i)%L .and. S ==LS_jj_f_6(i)%S .and. & J ==LS_jj_f_6(i)%J .and. Nm ==LS_jj_f_6(i)%Nm .and. & @@ -659,7 +659,7 @@ FUNCTION coefLSjjs(lshell,N,w,Q,L,S,J,Nm,Qm,Jm,Qp,Jp) result(wa) ! Use data from the array LS_jj_f_7 do i = 1, LS_jj_number_f7, 1 if (w == LS_jj_f_7(i)%w) then - if(Q == LS_jj_f_7(i)%Q) then + if(Q == LS_jj_f_7(i)%Q) then if(L == LS_jj_f_7(i)%L) then if(S == LS_jj_f_7(i)%S) then if(J == LS_jj_f_7(i)%J) then @@ -701,7 +701,7 @@ SUBROUTINE dallocASFLS(asf_set_LS) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE PRNT_C, ONLY: NVEC @@ -790,7 +790,7 @@ END SUBROUTINE getchLS ! !*********************************************************************** ! * - SUBROUTINE getxj + SUBROUTINE getxj ! * ! * ! Calls: jcup, jqs, ichop. * @@ -800,17 +800,17 @@ SUBROUTINE getxj ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE M_C, ONLY: NCORE - USE ORB_C, ONLY: NCF, NW + USE ORB_C, ONLY: NCF, NW !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE jqs_I - USE ichop_I - USE jcup_I + USE jqs_I + USE ichop_I + USE jcup_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -819,67 +819,67 @@ SUBROUTINE getxj !----------------------------------------------- Jcoup = 0 DO JNCF = 1, NCF - JCNT = 1 - JCNTOP = 0 + JCNT = 1 + JCNTOP = 0 DO JNW = NCORE+1, NW IF(JNW == 1) THEN - IF(ICHOP(JNW,JNCF) /= 0) THEN + IF(ICHOP(JNW,JNCF) /= 0) THEN IF(NW == 1) THEN Jcoup(JNW,JNCF) = 0 - ELSE + ELSE IF(ICHOP(JNW+1,JNCF) /= 0) THEN Jcoup(JNW,JNCF) = 0 Jcoup(JNW+1,JNCF) = 0 ELSE - Jcoup(JNW,JNCF) = 0 - Jcoup(JNW+1,JNCF) = JQS(3,JNW+1,JNCF) - 1 - JCNTOP = 1 + Jcoup(JNW,JNCF) = 0 + Jcoup(JNW+1,JNCF) = JQS(3,JNW+1,JNCF) - 1 + JCNTOP = 1 END IF END IF - ELSE - JCNTOP = 1 + ELSE + JCNTOP = 1 IF(NW > 1) THEN - IF (ICHOP(JNW+1,JNCF) == 0) THEN + IF (ICHOP(JNW+1,JNCF) == 0) THEN !GG 2015_06_21 Gediminas Gaigalas !GG Jcoup(JNW,JNCF) = JCUP(JCNT,JNCF) - 1 Jcoup(JNW,JNCF) = JQS(3,JNW,JNCF) - 1 Jcoup(JNW+1,JNCF) = JCUP(JCNT,JNCF) - 1 - JCNT = JCNT + 1 - ELSE + JCNT = JCNT + 1 + ELSE Jcoup(JNW,JNCF) = JQS(3,JNW,JNCF) - 1 - Jcoup(JNW+1,JNCF) = JQS(3,JNW,JNCF) - 1 + Jcoup(JNW+1,JNCF) = JQS(3,JNW,JNCF) - 1 ENDIF ELSE Jcoup(JNW,JNCF) = JCUP(JCNT,JNCF) - 1 - ENDIF - ENDIF + ENDIF + ENDIF ELSE IF(JNW == 2 .AND. NCORE+1 .EQ. 2) THEN - IF(ICHOP(JNW,JNCF) /= 0) THEN + IF(ICHOP(JNW,JNCF) /= 0) THEN Jcoup(JNW,JNCF) = 0 - ELSE - JCNTOP = 1 + ELSE + JCNTOP = 1 Jcoup(JNW,JNCF) = JQS(3,JNW,JNCF) - 1 - ENDIF + ENDIF ELSE IF(JNW > 2) THEN - IF (ICHOP(JNW,JNCF) /= 0) THEN + IF (ICHOP(JNW,JNCF) /= 0) THEN IF(JNW == NCORE+1) THEN Jcoup(JNW,JNCF) = JQS(3,JNW,JNCF) - 1 ELSE Jcoup(JNW,JNCF) = Jcoup(JNW-1,JNCF) END IF - ELSE - IF (JCNTOP /= 0) THEN - Jcoup(JNW,JNCF) = JCUP(JCNT,JNCF) - 1 - JCNT = JCNT + 1 - ELSE + ELSE + IF (JCNTOP /= 0) THEN + Jcoup(JNW,JNCF) = JCUP(JCNT,JNCF) - 1 + JCNT = JCNT + 1 + ELSE Jcoup(JNW,JNCF) = JQS(3,JNW,JNCF) - 1 - ENDIF - JCNTOP = JCNTOP + 1 - END IF - END IF - END DO - END DO - RETURN + ENDIF + JCNTOP = JCNTOP + 1 + END IF + END IF + END DO + END DO + RETURN END SUBROUTINE getxj ! !*********************************************************************** @@ -896,7 +896,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE jj2lsj_C IMPLICIT NONE @@ -919,7 +919,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) if (abs(M_Q) <= term_LS_s(i)%Q) then j = j + 1 LS(j)%l_shell = term_LS_s(i)%l_shell - LS(j)%w = term_LS_s(i)%w + LS(j)%w = term_LS_s(i)%w LS(j)%Q = term_LS_s(i)%Q LS(j)%LL = term_LS_s(i)%LL LS(j)%S = term_LS_s(i)%S @@ -932,7 +932,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) if (abs(M_Q) <= term_LS_p(i)%Q) then j = j + 1 LS(j)%l_shell = term_LS_p(i)%l_shell - LS(j)%w = term_LS_p(i)%w + LS(j)%w = term_LS_p(i)%w LS(j)%Q = term_LS_p(i)%Q LS(j)%LL = term_LS_p(i)%LL LS(j)%S = term_LS_p(i)%S @@ -945,7 +945,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) if (abs(M_Q) <= term_LS_d(i)%Q) then j = j + 1 LS(j)%l_shell = term_LS_d(i)%l_shell - LS(j)%w = term_LS_d(i)%w + LS(j)%w = term_LS_d(i)%w LS(j)%Q = term_LS_d(i)%Q LS(j)%LL = term_LS_d(i)%LL LS(j)%S = term_LS_d(i)%S @@ -958,7 +958,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) if (abs(M_Q) <= term_LS_f(i)%Q) then j = j + 1 LS(j)%l_shell = term_LS_f(i)%l_shell - LS(j)%w = term_LS_f(i)%w + LS(j)%w = term_LS_f(i)%w LS(j)%Q = term_LS_f(i)%Q LS(j)%LL = term_LS_f(i)%LL LS(j)%S = term_LS_f(i)%S @@ -970,7 +970,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_g1(i)%l_shell - LS(j)%w = term_LS_g1(i)%w + LS(j)%w = term_LS_g1(i)%w LS(j)%Q = term_LS_g1(i)%Q LS(j)%LL = term_LS_g1(i)%LL LS(j)%S = term_LS_g1(i)%S @@ -978,7 +978,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,9 j = j + 1 LS(j)%l_shell = term_LS_g2(i)%l_shell - LS(j)%w = term_LS_g2(i)%w + LS(j)%w = term_LS_g2(i)%w LS(j)%Q = term_LS_g2(i)%Q LS(j)%LL = term_LS_g2(i)%LL LS(j)%S = term_LS_g2(i)%S @@ -991,7 +991,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_h1(i)%l_shell - LS(j)%w = term_LS_h1(i)%w + LS(j)%w = term_LS_h1(i)%w LS(j)%Q = term_LS_h1(i)%Q LS(j)%LL = term_LS_h1(i)%LL LS(j)%S = term_LS_h1(i)%S @@ -999,7 +999,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,11 j = j + 1 LS(j)%l_shell = term_LS_h2(i)%l_shell - LS(j)%w = term_LS_h2(i)%w + LS(j)%w = term_LS_h2(i)%w LS(j)%Q = term_LS_h2(i)%Q LS(j)%LL = term_LS_h2(i)%LL LS(j)%S = term_LS_h2(i)%S @@ -1012,7 +1012,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_i1(i)%l_shell - LS(j)%w = term_LS_i1(i)%w + LS(j)%w = term_LS_i1(i)%w LS(j)%Q = term_LS_i1(i)%Q LS(j)%LL = term_LS_i1(i)%LL LS(j)%S = term_LS_i1(i)%S @@ -1020,7 +1020,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,13 j = j + 1 LS(j)%l_shell = term_LS_i2(i)%l_shell - LS(j)%w = term_LS_i2(i)%w + LS(j)%w = term_LS_i2(i)%w LS(j)%Q = term_LS_i2(i)%Q LS(j)%LL = term_LS_i2(i)%LL LS(j)%S = term_LS_i2(i)%S @@ -1033,7 +1033,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_k1(i)%l_shell - LS(j)%w = term_LS_k1(i)%w + LS(j)%w = term_LS_k1(i)%w LS(j)%Q = term_LS_k1(i)%Q LS(j)%LL = term_LS_k1(i)%LL LS(j)%S = term_LS_k1(i)%S @@ -1041,7 +1041,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,15 j = j + 1 LS(j)%l_shell = term_LS_k2(i)%l_shell - LS(j)%w = term_LS_k2(i)%w + LS(j)%w = term_LS_k2(i)%w LS(j)%Q = term_LS_k2(i)%Q LS(j)%LL = term_LS_k2(i)%LL LS(j)%S = term_LS_k2(i)%S @@ -1054,7 +1054,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_l1(i)%l_shell - LS(j)%w = term_LS_l1(i)%w + LS(j)%w = term_LS_l1(i)%w LS(j)%Q = term_LS_l1(i)%Q LS(j)%LL = term_LS_l1(i)%LL LS(j)%S = term_LS_l1(i)%S @@ -1062,7 +1062,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,17 j = j + 1 LS(j)%l_shell = term_LS_l2(i)%l_shell - LS(j)%w = term_LS_l2(i)%w + LS(j)%w = term_LS_l2(i)%w LS(j)%Q = term_LS_l2(i)%Q LS(j)%LL = term_LS_l2(i)%LL LS(j)%S = term_LS_l2(i)%S @@ -1075,7 +1075,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) case (1) i = 1; j = 1 LS(j)%l_shell = term_LS_m1(i)%l_shell - LS(j)%w = term_LS_m1(i)%w + LS(j)%w = term_LS_m1(i)%w LS(j)%Q = term_LS_m1(i)%Q LS(j)%LL = term_LS_m1(i)%LL LS(j)%S = term_LS_m1(i)%S @@ -1083,7 +1083,7 @@ SUBROUTINE gettermLS(l_shell,N,LS,number) do i = 1,19 j = j + 1 LS(j)%l_shell = term_LS_m2(i)%l_shell - LS(j)%w = term_LS_m2(i)%w + LS(j)%w = term_LS_m2(i)%w LS(j)%Q = term_LS_m2(i)%Q LS(j)%LL = term_LS_m2(i)%LL LS(j)%S = term_LS_m2(i)%S @@ -1102,7 +1102,7 @@ END SUBROUTINE gettermLS SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & UNIQUE) ! * -! The input from the screen. * +! The input from the screen. * ! * ! Calls: sercsla, getxj, getmixblock, inscreenlev, openfl. * ! inscreenlev. * @@ -1112,11 +1112,11 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE ORB_C, ONLY: NCF, NW - USE PRNT_C, ONLY: NVEC + USE PRNT_C, ONLY: NVEC USE IOUNIT_C, ONLY: ISTDI, ISTDE USE CONS_C, ONLY: EPS, ZERO USE BLK_C, ONLY: NEVINBLK, NBLOCK @@ -1153,7 +1153,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ! Open, check, load data from, and close, the .csl file CALL SETCSLA(NAME,NCORE) allocate(Jcoup(1:NW,1:NCF)) - CALL GETXJ + CALL GETXJ WRITE (ISTDE,*) WRITE (ISTDE,*) 'Mixing coefficients from a CI calc.?' YES = GETYN () @@ -1224,12 +1224,12 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & call inscreenlev(record,levels_tmp,number_of_levels_tmp,fail) if (fail) then WRITE (ISTDE,*) "Unable to interprete the serial level numbers; redo ..." - goto 2 + goto 2 end if number_of_levels(IBLOCK) = number_of_levels_tmp if (NVEC < number_of_levels(IBLOCK)) then WRITE (ISTDE,*) "There are to much ASF:", number_of_levels(IBLOCK) - go to 2 + go to 2 end if DO I = 1,number_of_levels_tmp levels(IBLOCK,I) = posi(IBLOCK) + levels_tmp(I) @@ -1237,7 +1237,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & WRITE (ISTDE,*) "" WRITE (ISTDE,*) "Do you need to include more levels? (y/n)" YES = GETYN () - IF (YES) go to 2 + IF (YES) go to 2 END IF 3 WRITE (ISTDE,*) 'Maximum % of omitted composition' READ *, MINCOMP @@ -1247,7 +1247,7 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ioutC = 1 ioutj = 1 ELSE IF( MINCOMP > ZERO) THEN - IMINCOMPOFF = 1 + IMINCOMPOFF = 1 WRITE (ISTDE,*) 'What is the value below which an eigenvector component' WRITE (ISTDE,*) 'is to be neglected in the determination of the LSJ expansion:' WRITE (ISTDE,'(A,F8.5)') ' should be smaller than:',MINCOMP*0.01 @@ -1266,14 +1266,14 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & ioutC = 1 ELSE ioutC = 0 - END IF + END IF WRITE (ISTDE,*) "Do you need the output file *.lsj.j? (y/n)" YES = GETYN () IF (YES) THEN ioutj = 1 ELSE ioutj = 0 - END IF + END IF END IF ENDIF ! @@ -1320,10 +1320,10 @@ SUBROUTINE inscreen(THRESH,levels,number_of_levels,ioutC,ioutj, & STOP ENDIF END IF -!GG-2017 end +!GG-2017 end write(57,'(A53)') " Pos J Parity Energy Total Comp. of ASF" ! -! Opening the files *.lsj.j and +! Opening the files *.lsj.j and ! IF(ioutj == 1) THEN util_csl_file = NAME(1:K-1)//'.lsj'//'.j' @@ -1360,13 +1360,13 @@ SUBROUTINE inscreenlev(record,levels,number_of_levels,fail) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE idigit_I + USE idigit_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -1441,7 +1441,7 @@ END SUBROUTINE inscreenlev ! * SUBROUTINE jj2lsj ! * -! Controls the transformation of atomic states from a jj- * +! Controls the transformation of atomic states from a jj- * ! to a LS-coupled CSF basis. * ! * ! Calls: asf2LS, convrt_double, dallocASFLS, inscreen, ispar, * @@ -1453,7 +1453,7 @@ SUBROUTINE jj2lsj ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE EIGV_C, ONLY: EAV, EVAL, EVEC @@ -1490,7 +1490,7 @@ SUBROUTINE jj2lsj integer, dimension(:), pointer :: iw !GG real(DOUBLE), dimension(1:100) :: weights, weights2 real(DOUBLE), dimension(:), pointer :: weights, weights2 - integer, dimension(:), pointer :: ithresh + integer, dimension(:), pointer :: ithresh !GG character(LEN=64), dimension(1:Vectors_number) :: string_CSF character(LEN=164), dimension(1:Vectors_number) :: string_CSF !----------------------------------------------- @@ -1500,16 +1500,16 @@ SUBROUTINE jj2lsj do IBLKNUM = 1, NBLOCK if(IBLKNUM == 1) THEN NCFMIN = 1 - NCFMAX = NCFINBLK(IBLKNUM) + NCFMAX = NCFINBLK(IBLKNUM) else NCFMIN = NCFMAX + 1 NCFMAX = NCFMIN + NCFINBLK(IBLKNUM) - 1 end if - if(number_of_levels(IBLKNUM) == 0) GO TO 1 + if(number_of_levels(IBLKNUM) == 0) GO TO 1 ithresh = 0 do i = NCFMIN, NCFMAX sumthrsh = ZERO - do lev = 1, number_of_levels(IBLKNUM) + do lev = 1, number_of_levels(IBLKNUM) level = levels(IBLKNUM,lev) LOC = (level-1)*NCF sumthrsh = sumthrsh + dabs(EVEC(i+LOC)) @@ -1537,13 +1537,13 @@ SUBROUTINE jj2lsj allocate (weights(NCF_LS_jj_MAX)) allocate (weights2(NCF_LS_jj_MAX)) allocate (iw(NCF_LS_jj_MAX)) - do lev = 1, number_of_levels(IBLKNUM) + do lev = 1, number_of_levels(IBLKNUM) level = levels(IBLKNUM,lev) - weights = ZERO; iw = 0; wb = ZERO + weights = ZERO; iw = 0; wb = ZERO do i = NCFMIN, NCFMAX if(ithresh(i) == 1) then LOC = (level-1)*NCF - wa = EVEC(i+LOC) * EVEC(i+LOC) + wa = EVEC(i+LOC) * EVEC(i+LOC) wb = wb + wa do j = 1,999 if (wa > weights(j)) then @@ -1559,7 +1559,7 @@ SUBROUTINE jj2lsj if(lev == 1) then print *, " " WRITE(*,'(A,A)') " . . . . . . . . . . . . . . .",& - " . . . . . . . . . . . . . . . . . . . ." + " . . . . . . . . . . . . . . . . . . . ." WRITE(*, '(A,2X,I4,16X,A,I3)') & " Under investigation is the block:",IBLKNUM, & " The number of eigenvectors:", number_of_levels(IBLKNUM) @@ -1568,7 +1568,7 @@ SUBROUTINE jj2lsj " The number of CSF (in LS-coupling):",asf_set_LS%csf_set_LS%nocsf else print *, " " - WRITE(*,'(A)') " . . . . . . . . . . . . . . . . . ." + WRITE(*,'(A)') " . . . . . . . . . . . . . . . . . ." WRITE(*,'(A)') " The new level is under investigation." end if ! @@ -1584,7 +1584,7 @@ SUBROUTINE jj2lsj print *, " " if (level > 1 .and. dabs(wb) > 1.0001) then print *, "level, wb = ",level,wb - stop "JJ2LSJ(): program stop A." + stop "JJ2LSJ(): program stop A." end if nocsf_min = 5 do j = 1,5 @@ -1621,7 +1621,7 @@ SUBROUTINE jj2lsj sum_nocsf_min = 0 weights = ZERO; weights2 = ZERO; iw = 0; wb = ZERO do i = 1,asf_set_LS%csf_set_LS%nocsf - wa = asf_set_LS%asf(level)%eigenvector(i) + wa = asf_set_LS%asf(level)%eigenvector(i) wb = wb + wa*wa !GG NIST if(i == 1) then @@ -1700,14 +1700,14 @@ SUBROUTINE jj2lsj ! ! output to *.lsj.lbl IF(Before_J == 0) THEN - Before_J = 1 + Before_J = 1 ELSE IF(lev == 1 .and. Before_J == 1) THEN write(57,'(A1)') ' ' END IF DO j = 1,nocsf_min CALL packlsCSF(asf_set_LS%csf_set_LS,iw(j),string_CSF_ONE) IF(J == 1) THEN - write(57,'(1X,I2,1X,A4,5X,A1,8X,F16.9,5X,F7.3,A)') & + write(57,'(1X,I2,1X,A4,5X,A1,8X,F16.9,5X,F7.3,A)') & asf_set_LS%asf(level)%level_No,string_CNUM(1:string_l),& asf_set_LS%csf_set_LS%csf(iw(1))%parity, & asf_set_LS%asf(level)%energy,wb*100,"%" @@ -1716,7 +1716,7 @@ SUBROUTINE jj2lsj string_length = Len_Trim(string_CSF_ONE) write(57,'(7X,F12.8,3X,F11.8,3X,A)') weights(j),weights2(j),string_CSF_ONE(1:string_length) END DO -! output *.lsj.j and +! output *.lsj.j and IF(ioutj == 1) THEN IF(lev == 1) THEN WRITE (58, '(//A8,I4,2X,A8,I4)' ) ' 2*J = ', & @@ -1805,7 +1805,7 @@ SUBROUTINE packlsCSF(csf_set_LS,csf_number,string_CSF) allocate(occupation(csf_set_LS%nwshells)) allocate(string_LS(csf_set_LS%nwshells)) allocate(string_XLS(csf_set_LS%nwshells)) - do j = csf_set_LS%nwcore+1, csf_set_LS%nwshells + do j = csf_set_LS%nwcore+1, csf_set_LS%nwshells if (csf_set_LS%csf(csf_number)%occupation(j) > 0) then counter = counter +1; occupation(counter) = j call getchLS(csf_number,j,LS,XLS) @@ -1830,7 +1830,7 @@ SUBROUTINE packlsCSF(csf_set_LS,csf_number,string_CSF) COUPLE(I+counter-1)(1:3) = string_XLS(I)(1:3) END IF Q(I) = csf_set_LS%csf(csf_number)%occupation(occupation(I)) - ELC(I)(1:3) = String_NL(I)(1:3) + ELC(I)(1:3) = String_NL(I)(1:3) END DO CALL PACKLS(counter,ELC,Q,COUPLE,string_CSF_pack) string_CSF = string_CSF_pack @@ -1854,7 +1854,7 @@ SUBROUTINE prCSFjj(stream,csf_number,csf_number_local) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE ORB_C, ONLY: NW, NP, NAK @@ -1911,8 +1911,8 @@ SUBROUTINE prCSFjj(stream,csf_number,csf_number_local) write(String,'(I2)')NP(occupation(I)) String_NL(I)(1:2) = String(1:2) J = ((IABS(NAK(occupation(I)))*2)-1+ & - NAK(occupation(I))/IABS(NAK(occupation(I))))/2 - String_NL(I)(3:3) = L1(J) + NAK(occupation(I))/IABS(NAK(occupation(I))))/2 + String_NL(I)(3:3) = L1(J) IF(NAK(occupation(I)) <= 0) THEN String_NL(I)(4:4) = " " ELSE @@ -1972,7 +1972,7 @@ SUBROUTINE prCSFLS(stream,csf_set_LS,csf_number) allocate(occupation(csf_set_LS%nwshells)) allocate(string_LS(csf_set_LS%nwshells)) allocate(string_XLS(csf_set_LS%nwshells)) - do j = csf_set_LS%nwcore+1, csf_set_LS%nwshells + do j = csf_set_LS%nwcore+1, csf_set_LS%nwshells if (csf_set_LS%csf(csf_number)%occupation(j) > 0) then counter = counter +1; occupation(counter) = j call getchLS(csf_number,j,LS,XLS) @@ -2023,7 +2023,7 @@ SUBROUTINE prCSFLSall(stream,csf_set_LS,Before_J) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE @@ -2036,7 +2036,7 @@ SUBROUTINE prCSFLSall(stream,csf_set_LS,Before_J) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: I, J + integer :: I, J CHARACTER (LEN=2) :: String CHARACTER (LEN=3), DIMENSION(:), POINTER :: String_NL CHARACTER (LEN=1), DIMENSION(0:20) :: L1 @@ -2083,7 +2083,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE DEF_C, ONLY: NELEC @@ -2098,8 +2098,8 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer, dimension(:), intent(in) :: ithresh - integer, intent(in) :: NCFMIN, NCFMAX + integer, dimension(:), intent(in) :: ithresh + integer, intent(in) :: NCFMIN, NCFMAX !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -2108,14 +2108,14 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) type(lsj_list) :: nonequiv_csfs_jj ! integer :: isubc, isubc2, icsf_jj, icsf_jj2, icsf_jj_real, icsf_LS - integer :: N, action_type + integer :: N, action_type logical :: new_one, found_parent_minus, found_parent_plus ! integer, dimension(:), pointer :: all_occupation integer, dimension(:), pointer :: Li, Si, L_i, S_i, w, Q integer :: J !----------------------------------------------- - asf_set_LS%csf_set_LS%number_of_electrons = NELEC + asf_set_LS%csf_set_LS%number_of_electrons = NELEC ! ! 1. define nl, parent allocate(shell_temp(NW)); allocate(nlLSval(NW)); allocate(nljjval(NW)) @@ -2133,7 +2133,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) asf_set_LS%csf_set_LS%nwshells = asf_set_LS%csf_set_LS%nwshells + 1 shell_temp(asf_set_LS%csf_set_LS%nwshells)%n = NP(isubc) shell_temp(asf_set_LS%csf_set_LS%nwshells)%l= & - ((IABS(NAK(isubc))*2)-1+NAK(isubc)/IABS(NAK(isubc)))/2 + ((IABS(NAK(isubc))*2)-1+NAK(isubc)/IABS(NAK(isubc)))/2 nlLSval(asf_set_LS%csf_set_LS%nwshells) = nljjval(isubc) end if end do @@ -2151,7 +2151,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) do isubc = 1, asf_set_LS%csf_set_LS%nwshells, 1 found_parent_minus = .false.; found_parent_plus = .false. do isubc2 = 1, NW, 1 - if(nlLSval(isubc) == nljjval(isubc2)) then + if(nlLSval(isubc) == nljjval(isubc2)) then if(NAK(isubc2) > 0) then found_parent_minus = .true. asf_set_LS%csf_set_LS%parent(isubc)%parent_minus = isubc2 @@ -2161,7 +2161,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) end if end if end do - if(.not.found_parent_plus) & + if(.not.found_parent_plus) & asf_set_LS%csf_set_LS%parent(isubc)%parent_plus = 0 if(.not.found_parent_minus) & asf_set_LS%csf_set_LS%parent(isubc)%parent_minus = 0 @@ -2170,7 +2170,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) ! end find parent -------------------- ! ! 2. define the number of "core" shells -! (the LS shell is supposed to be "core" if: +! (the LS shell is supposed to be "core" if: ! 1. l=0 and corresponding jj subshell is "core" ! 2. l<>0 l+ and l - "core" subshells ) asf_set_LS%csf_set_LS%nwcore=0 @@ -2181,20 +2181,20 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) asf_set_LS%csf_set_LS%nwcore = asf_set_LS%csf_set_LS%nwcore+1 end do ! -! 3. form the list of "nonequivalent" csfs_jj +! 3. form the list of "nonequivalent" csfs_jj ! (i.e. csfs_jj different in J,parity, or ! some l's occupation numbers Ni = N_(i+) + N_(i-)) allocate(nonequiv_csfs_jj%items(NCF)) nonequiv_csfs_jj%list_size = 0 do icsf_jj = NCFMIN, NCFMAX new_one = .true. - if(ithresh(icsf_jj) == 1) then + if(ithresh(icsf_jj) == 1) then do icsf_jj2 = NCFMIN , icsf_jj - 1 - if(ithresh(icsf_jj2) == 1) then + if(ithresh(icsf_jj2) == 1) then if(setLS_equivalent_csfs(icsf_jj,icsf_jj2)) then new_one = .false. exit - end if + end if end if end do if(new_one) then @@ -2204,10 +2204,10 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) end if end do ! -! 4. for each nonequivalent csf_jj find all the csfs_LS -! -! To avoid the dependency on the number of subshells -! the recursive subroutine is used +! 4. for each nonequivalent csf_jj find all the csfs_LS +! +! To avoid the dependency on the number of subshells +! the recursive subroutine is used allocate(Li(asf_set_LS%csf_set_LS%nwshells)) allocate(L_i(asf_set_LS%csf_set_LS%nwshells)) allocate(Si(asf_set_LS%csf_set_LS%nwshells)) @@ -2231,7 +2231,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) all_occupation(isubc) = 0 do isubc2 = 1, NW, 1 if(nlLSval(isubc) == nljjval(isubc2)) & - all_occupation(isubc)=all_occupation(isubc)+IQ(isubc2,icsf_jj_real) + all_occupation(isubc)=all_occupation(isubc)+IQ(isubc2,icsf_jj_real) end do !isubc2 ! end do !isubc @@ -2265,7 +2265,7 @@ SUBROUTINE setLS(ithresh,NCFMIN,NCFMAX) all_occupation(isubc)=0 do isubc2 = 1, NW, 1 if(nlLSval(isubc) == nljjval(isubc2)) & - all_occupation(isubc)=all_occupation(isubc)+IQ(isubc2,icsf_jj_real) + all_occupation(isubc)=all_occupation(isubc)+IQ(isubc2,icsf_jj_real) end do !isubc2 end do !isubc action_type = 2 @@ -2328,7 +2328,7 @@ SUBROUTINE setLS_add_quantum_numbers() ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- @@ -2342,16 +2342,16 @@ SUBROUTINE setLS_add_quantum_numbers() integer :: isubcx !----------------------------------------------- icsf_LS = icsf_LS + 1 -! +! if(icsf_LS .gt. asf_set_LS%csf_set_LS%nocsf) then stop 'setLS_add_quantum_numbers(): program stop A.' end if ! - asf_set_LS%csf_set_LS%csf(icsf_LS)%totalJ = J + asf_set_LS%csf_set_LS%csf(icsf_LS)%totalJ = J ! - IF (ISPAR(icsf_jj_real) == 1) THEN - asf_set_LS%csf_set_LS%csf(icsf_LS)%parity = "+" - ELSE IF (ISPAR(icsf_jj_real) == -1) THEN + IF (ISPAR(icsf_jj_real) == 1) THEN + asf_set_LS%csf_set_LS%csf(icsf_LS)%parity = "+" + ELSE IF (ISPAR(icsf_jj_real) == -1) THEN asf_set_LS%csf_set_LS%csf(icsf_LS)%parity = "-" END IF ! @@ -2360,13 +2360,13 @@ SUBROUTINE setLS_add_quantum_numbers() all_occupation(isubcx) asf_set_LS%csf_set_LS%csf(icsf_LS)%shellL(isubcx) = Li(isubcx) asf_set_LS%csf_set_LS%csf(icsf_LS)%shellS(isubcx) = Si(isubcx) - asf_set_LS%csf_set_LS%csf(icsf_LS)%shellLX(isubcx) = L_i(isubcx) + asf_set_LS%csf_set_LS%csf(icsf_LS)%shellLX(isubcx) = L_i(isubcx) asf_set_LS%csf_set_LS%csf(icsf_LS)%shellSX(isubcx) = S_i(isubcx) asf_set_LS%csf_set_LS%csf(icsf_LS)%w(isubcx) = w(isubcx) asf_set_LS%csf_set_LS%csf(icsf_LS)%seniority(isubcx) = & 2*asf_set_LS%csf_set_LS%shell(isubcx)%l + 1 - Q(isubcx) end do - END SUBROUTINE setLS_add_quantum_numbers + END SUBROUTINE setLS_add_quantum_numbers ! !*********************************************************************** ! * @@ -2382,7 +2382,7 @@ RECURSIVE SUBROUTINE setLS_job_count(isubc, rez) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE jj2lsj_C @@ -2421,7 +2421,7 @@ RECURSIVE SUBROUTINE setLS_job_count(isubc, rez) else if(ittk(S_i(isubc),L_i(isubc),J).eq.1) & call setLS_action(action_type, rez) !rez=rez+1 - end if + end if else Li(isubc) = 0; L_i(isubc) = 0 Si(isubc) = 0; S_i(isubc) = 0 @@ -2445,7 +2445,7 @@ RECURSIVE SUBROUTINE setLS_job_count(isubc, rez) S_i(isubc) = LS_terms(iterm)%S if(asf_set_LS%csf_set_LS%nwshells.gt.1) then call setLS_job_count(isubc + 1, rez) - else + else if(ittk(S_i(isubc),L_i(isubc),J).eq.1) & call setLS_action(action_type, rez) !rez=rez+1 end if @@ -2487,7 +2487,7 @@ FUNCTION setLS_equivalent_csfs(ncsf1,ncsf2) result(rez) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE ORB_C, ONLY: NW @@ -2511,16 +2511,16 @@ FUNCTION setLS_equivalent_csfs(ncsf1,ncsf2) result(rez) rez= .true. IF(ITJPO(ncsf1) /= ITJPO(ncsf2)) THEN rez = .false. - ELSE IF (ISPAR(ncsf1) /= ISPAR(ncsf2)) THEN + ELSE IF (ISPAR(ncsf1) /= ISPAR(ncsf2)) THEN rez = .false. ELSE do isubc_LS = asf_set_LS%csf_set_LS%nwcore + 1, & asf_set_LS%csf_set_LS%nwshells, 1 NLS1 = 0; NLS2 = 0 do isubc_jj = 1, NW, 1 - if(nlLSval(isubc_LS) == nljjval(isubc_jj)) then + if(nlLSval(isubc_LS) == nljjval(isubc_jj)) then NLS1 = NLS1 + IQ(isubc_jj,ncsf1) - NLS2 = NLS2 + IQ(isubc_jj,ncsf2) + NLS2 = NLS2 + IQ(isubc_jj,ncsf2) end if end do if(NLS1.ne.NLS2) then @@ -2548,7 +2548,7 @@ FUNCTION traLSjj(jj_number,LS_number) result(wa) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE ORB_C, ONLY: NAK @@ -2605,7 +2605,7 @@ FUNCTION traLSjj(jj_number,LS_number) result(wa) l_shell=asf_set_LS%csf_set_LS%shell(shell_number)%l N_LS =asf_set_LS%csf_set_LS%csf(LS_number)%occupation(shell_number) W_1 =asf_set_LS%csf_set_LS%csf(LS_number)%w(shell_number) - Q_1 =2*l_shell+1- & + Q_1 =2*l_shell+1- & asf_set_LS%csf_set_LS%csf(LS_number)%seniority(shell_number) ! L_1 = asf_set_LS%csf_set_LS%csf(LS_number)%shellL(shell_number) @@ -2649,7 +2649,7 @@ FUNCTION traLSjjmp(shell_number,jj_number,LS_number) result(wa) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE ORB_C, ONLY: NAK @@ -2780,7 +2780,7 @@ SUBROUTINE uniquelsj ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- diff --git a/src/appl/jj2lsj90/jj2lsj_data_1_C.f90 b/src/appl/jj2lsj90/jj2lsj_data_1_C.f90 index 2f1d69f72..c26ef7942 100644 --- a/src/appl/jj2lsj90/jj2lsj_data_1_C.f90 +++ b/src/appl/jj2lsj90/jj2lsj_data_1_C.f90 @@ -13,7 +13,7 @@ MODULE jj2lsj_data_1_C ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE jj2lsj_C !----------------------------------------------- @@ -21,7 +21,7 @@ MODULE jj2lsj_data_1_C ! w,2Q,2L,2S,2J, Nm,2Qm,2Jm,2Qp,2Jp,fac,nom,denom ! p^3 shell type(LS_jj_me), dimension(1:10), parameter :: & - LS_jj_p_3 = (/ & + LS_jj_p_3 = (/ & LS_jj_me(0, 2, 2, 1, 1, 1, 0, 1, 2, 0, 1, 1, 1), & LS_jj_me(0, 0, 0, 3, 3, 0, 1, 0, 1, 3,-1, 2, 9), & LS_jj_me(0, 0, 0, 3, 3, 1, 0, 1, 0, 4, 1, 5, 9), & @@ -36,7 +36,7 @@ MODULE jj2lsj_data_1_C ! p^4 shell type(LS_jj_me), dimension(1:9), parameter :: & LS_jj_p_4 = (/ & - LS_jj_me(0, 3, 0, 0, 0, 0, 1, 0, 2, 0, 1, 1, 3), & + LS_jj_me(0, 3, 0, 0, 0, 0, 1, 0, 2, 0, 1, 1, 3), & LS_jj_me(0, 3, 0, 0, 0, 2, 1, 0, 2, 0, 1, 2, 3), & LS_jj_me(0, 1, 2, 2, 0, 0, 1, 0, 2, 0,-1, 2, 3), & LS_jj_me(0, 1, 2, 2, 0, 2, 1, 0, 2, 0, 1, 1, 3), & @@ -724,7 +724,7 @@ MODULE jj2lsj_data_1_C LS_jj_me(0, 2,10, 1,11, 3, 1, 3, 1, 8,-1, 1, 1) /) ! ! d^8 shell - type(LS_jj_me), dimension(1:19), parameter :: & + type(LS_jj_me), dimension(1:19), parameter :: & LS_jj_d_8 = (/ & LS_jj_me(0, 5, 0, 0, 0, 2, 2, 0, 3, 0, 1, 2, 5), & LS_jj_me(0, 5, 0, 0, 0, 4, 2, 0, 3, 0, 1, 3, 5), & @@ -6004,6 +6004,6 @@ MODULE jj2lsj_data_1_C LS_jj_me(0, 2,22, 1,23, 2, 1, 8, 1,15, 1, 1, 1) /) ! type(LS_jj_me), dimension(1:3799), parameter :: & - LS_jj_f_5 = (/LS_jj_f_5_1, LS_jj_f_5_2, LS_jj_f_5_3, LS_jj_f_5_4/) + LS_jj_f_5 = (/LS_jj_f_5_1, LS_jj_f_5_2, LS_jj_f_5_3, LS_jj_f_5_4/) ! END MODULE jj2lsj_data_1_C diff --git a/src/appl/jj2lsj90/jj2lsj_data_2_C.f90 b/src/appl/jj2lsj90/jj2lsj_data_2_C.f90 index 0675b9a84..98da81d65 100644 --- a/src/appl/jj2lsj90/jj2lsj_data_2_C.f90 +++ b/src/appl/jj2lsj90/jj2lsj_data_2_C.f90 @@ -11,7 +11,7 @@ MODULE jj2lsj_data_2_C ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE jj2lsj_C !----------------------------------------------- diff --git a/src/appl/jj2lsj90/jj2lsj_data_3_C.f90 b/src/appl/jj2lsj90/jj2lsj_data_3_C.f90 index 7f298d965..b38a04c36 100644 --- a/src/appl/jj2lsj90/jj2lsj_data_3_C.f90 +++ b/src/appl/jj2lsj90/jj2lsj_data_3_C.f90 @@ -11,7 +11,7 @@ MODULE jj2lsj_data_3_C ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE jj2lsj_C !----------------------------------------------- diff --git a/src/appl/jj2lsj90/lval.f90 b/src/appl/jj2lsj90/lval.f90 index d5d091f76..2027ea7e4 100644 --- a/src/appl/jj2lsj90/lval.f90 +++ b/src/appl/jj2lsj90/lval.f90 @@ -1,36 +1,36 @@ ! !*********************************************************************** ! * - INTEGER FUNCTION LVAL (SYMBOL) -! * + INTEGER FUNCTION LVAL (SYMBOL) +! * ! Modified by Gediminas Gaigalas, September 1997 * ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 21:52:17 11/14/01 -!...Switches: +!...Translated by Pacific-Sierra Research 77to90 4.3E 21:52:17 11/14/01 +!...Switches: !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: SYMBOL + CHARACTER , INTENT(IN) :: SYMBOL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LOCATE - CHARACTER(LEN=26) :: SET + INTEGER :: LOCATE + CHARACTER(LEN=26) :: SET ! - DATA SET/ 'spdfghiklmnoqSPDFGHIKLMNOQ'/ -!----------------------------------------------- - LOCATE = INDEX(SET,SYMBOL) - IF (LOCATE <= 13) THEN - LVAL = LOCATE - 1 - ELSE - LVAL = LOCATE - 14 - ENDIF - RETURN - END FUNCTION LVAL + DATA SET/ 'spdfghiklmnoqSPDFGHIKLMNOQ'/ +!----------------------------------------------- + LOCATE = INDEX(SET,SYMBOL) + IF (LOCATE <= 13) THEN + LVAL = LOCATE - 1 + ELSE + LVAL = LOCATE - 14 + ENDIF + RETURN + END FUNCTION LVAL diff --git a/src/appl/jj2lsj90/packLS.f90 b/src/appl/jj2lsj90/packLS.f90 index b815e4e98..19241e112 100644 --- a/src/appl/jj2lsj90/packLS.f90 +++ b/src/appl/jj2lsj90/packLS.f90 @@ -1,7 +1,7 @@ ! !*********************************************************************** ! * - SUBROUTINE PACKLS(M, EL, Q, COUPLE, STR) + SUBROUTINE PACKLS(M, EL, Q, COUPLE, STR) ! * ! Subroutine written by Bin LIU * ! * @@ -15,101 +15,101 @@ SUBROUTINE PACKLS(M, EL, Q, COUPLE, STR) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 21:52:17 11/14/01 -!...Switches: +!...Translated by Pacific-Sierra Research 77to90 4.3E 21:52:17 11/14/01 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lval_I + USE lval_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: M -!GG CHARACTER(LEN=64), INTENT(OUT) :: STR - CHARACTER(LEN=164), INTENT(OUT) :: STR - INTEGER, INTENT(IN) :: Q(*) - CHARACTER(LEN=3), INTENT(IN) :: EL(*), COUPLE(*) + INTEGER, INTENT(IN) :: M +!GG CHARACTER(LEN=64), INTENT(OUT) :: STR + CHARACTER(LEN=164), INTENT(OUT) :: STR + INTEGER, INTENT(IN) :: Q(*) + CHARACTER(LEN=3), INTENT(IN) :: EL(*), COUPLE(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: FULL, CONST, J, I, K, N - CHARACTER(LEN=1) :: CH1 - CHARACTER(LEN=3) :: CH3 + INTEGER :: FULL, CONST, J, I, K, N + CHARACTER(LEN=1) :: CH1 + CHARACTER(LEN=3) :: CH3 !----------------------------------------------- ! FULL : 4l+2 ! CONST : constant for converting lowercase to uppercase ! CH* : temporary variables ! - CONST = ICHAR('a') - ICHAR('A') - STR = ' ' - J = 1 + CONST = ICHAR('a') - ICHAR('A') + STR = ' ' + J = 1 ! ! ----- begin to encode ----- ! - DO I = 1, M - IF (Q(I) == 0) CYCLE - IF (EL(I)(1:1) == ' ') THEN - STR(J:J+1) = EL(I)(2:3) - K = 2 - ELSE - STR(J:J+2) = EL(I) - K = 3 - IF (EL(I)(3:3) == ' ') K = 2 - ENDIF - CH1 = STR(J+1:J+1) - IF (CH1>='A' .AND. CH1<='Z') STR(J+1:J+1) = CHAR(ICHAR(CH1) + CONST) - FULL = 4*LVAL(CH1) + 2 + DO I = 1, M + IF (Q(I) == 0) CYCLE + IF (EL(I)(1:1) == ' ') THEN + STR(J:J+1) = EL(I)(2:3) + K = 2 + ELSE + STR(J:J+2) = EL(I) + K = 3 + IF (EL(I)(3:3) == ' ') K = 2 + ENDIF + CH1 = STR(J+1:J+1) + IF (CH1>='A' .AND. CH1<='Z') STR(J+1:J+1) = CHAR(ICHAR(CH1) + CONST) + FULL = 4*LVAL(CH1) + 2 ! ! ----- convert Qi into character ----- ! - J = J + K - N = Q(I) - IF (N > 14) STOP 'Too many electrons' + J = J + K + N = Q(I) + IF (N > 14) STOP 'Too many electrons' ! ! ----- If Qi<>1, add Qi ! If Qi<4l+1, add TERMi for the shell ----- ! - IF (N /= 1) THEN - STR(J:J) = '(' - J = J + 1 - IF (N > 9) THEN - STR(J:J) = '1' - J = J + 1 - N = N - 10 - ENDIF - STR(J:J+1) = CHAR(ICHAR('0') + N)//')' - J = J + 2 - IF (N='a' .AND. CH1<='z') CH3(2:2) = CHAR(ICHAR(CH1) - CONST) - STR(J:J+2) = CH3 - J = J + 3 - ENDIF - ENDIF + IF (N /= 1) THEN + STR(J:J) = '(' + J = J + 1 + IF (N > 9) THEN + STR(J:J) = '1' + J = J + 1 + N = N - 10 + ENDIF + STR(J:J+1) = CHAR(ICHAR('0') + N)//')' + J = J + 2 + IF (N='a' .AND. CH1<='z') CH3(2:2) = CHAR(ICHAR(CH1) - CONST) + STR(J:J+2) = CH3 + J = J + 3 + ENDIF + ENDIF ! ! ----- If i=1 or Qi=4l+2 and i<>m, ! insert '.'; else _RESULTANTi. ----- ! - IF (I/=1 .AND. N/=FULL .OR. M==I) THEN - CH3 = COUPLE(M+I-1) - CH1 = CH3(2:2) - IF (CH1>='a' .AND. CH1<='z') CH3(2:2) = CHAR(ICHAR(CH1) - CONST) - K = 2 - IF (M == 1) K = 3 - STR(J:J+K) = '_'//CH3(1:K) - J = J + K + 1 - ENDIF - IF (I == M) CYCLE - STR(J:J) = '.' - J = J + 1 - END DO + IF (I/=1 .AND. N/=FULL .OR. M==I) THEN + CH3 = COUPLE(M+I-1) + CH1 = CH3(2:2) + IF (CH1>='a' .AND. CH1<='z') CH3(2:2) = CHAR(ICHAR(CH1) - CONST) + K = 2 + IF (M == 1) K = 3 + STR(J:J+K) = '_'//CH3(1:K) + J = J + K + 1 + ENDIF + IF (I == M) CYCLE + STR(J:J) = '.' + J = J + 1 + END DO ! !>>>>> Because of a compiler error on the SUN, the following is ! needed to have the string printed correctly. ! STR = STR(1:J) - RETURN - END SUBROUTINE PACKLS + RETURN + END SUBROUTINE PACKLS diff --git a/src/appl/jjgen90/Makefile b/src/appl/jjgen90/Makefile old mode 100755 new mode 100644 index 2448b0897..3fa70d5bd --- a/src/appl/jjgen90/Makefile +++ b/src/appl/jjgen90/Makefile @@ -31,5 +31,4 @@ $(EXE): $(MOD_OBJ) $(APP_OBJ) $(FC) -c $< -I . -o $@ clean: - -rm -f *.o *.mod core - + -rm -f *.o *.mod core diff --git a/src/appl/jjgen90/adder.f90 b/src/appl/jjgen90/adder.f90 index 4ff4adc1b..6e5601162 100644 --- a/src/appl/jjgen90/adder.f90 +++ b/src/appl/jjgen90/adder.f90 @@ -1,112 +1,112 @@ ! last edited July 31, 1996 - subroutine adder(closed, med, slut, anel, par, expand) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine adder(closed, med, slut, anel, par, expand) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use lockad_I - use lasa1_I + use lockad_I + use lasa1_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(out) :: anel - integer , intent(out) :: par - logical :: slut - logical :: expand - logical :: closed(15,0:10) - logical :: med(15,0:10) + integer , intent(out) :: anel + integer , intent(out) :: par + logical :: slut + logical :: expand + logical :: closed(15,0:10) + logical :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop - integer :: skal, i, j, kl, nr - logical :: finns - character :: rad1*500, rad2*500, rad3*500 + integer , dimension(15,0:10,0:1) :: pop + integer :: skal, i, j, kl, nr + logical :: finns + character :: rad1*500, rad2*500, rad3*500 !----------------------------------------------- - skal = 20 - inquire(file='clist.inp', exist=finns) - if (finns) then - if (.not.expand) then - open(unit=fil_1, file='clist.inp', status='old', position='asis') - else - open(unit=fil_2, file='clist.inp', status='old', position='asis') - endif - slut = .FALSE. - call lockad (closed, med, slut, expand) - if (.not.slut) then - if (expand) then - read (fil_2, *, end=99) - call lasa1 (fil_2, rad1, pop, skal, slut) - else - read (fil_1, *, end=99) - call lasa1 (fil_1, rad1, pop, skal, slut) - endif - endif - if (.not.slut) then - anel = 0 - par = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - if (closed(i,j)) then - anel = anel + 2 + 4*j - else - anel = anel + pop(i,j,0) + pop(i,j,1) - par = mod(par + j*(pop(i,j,0)+pop(i,j,1)),2) - endif - end do - end do - if (expand) then - read (fil_2, 100, end=99) rad2 - read (fil_2, 100, end=99) rad3 - else - read (fil_1, 100, end=99) rad2 - read (fil_1, 100, end=99) rad3 - endif - kl = skal*9 - if (rad3(kl:kl) /= '/') then - if (rad3(kl:kl) /= ' ') then - nr = 10*(ichar(rad3(kl:kl))-ichar('0')) - else - nr = 0 - endif - kl = kl + 1 + skal = 20 + inquire(file='clist.inp', exist=finns) + if (finns) then + if (.not.expand) then + open(unit=fil_1, file='clist.inp', status='old', position='asis') + else + open(unit=fil_2, file='clist.inp', status='old', position='asis') + endif + slut = .FALSE. + call lockad (closed, med, slut, expand) + if (.not.slut) then + if (expand) then + read (fil_2, *, end=99) + call lasa1 (fil_2, rad1, pop, skal, slut) + else + read (fil_1, *, end=99) + call lasa1 (fil_1, rad1, pop, skal, slut) + endif + endif + if (.not.slut) then + anel = 0 + par = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + if (closed(i,j)) then + anel = anel + 2 + 4*j + else + anel = anel + pop(i,j,0) + pop(i,j,1) + par = mod(par + j*(pop(i,j,0)+pop(i,j,1)),2) + endif + end do + end do + if (expand) then + read (fil_2, 100, end=99) rad2 + read (fil_2, 100, end=99) rad3 + else + read (fil_1, 100, end=99) rad2 + read (fil_1, 100, end=99) rad3 + endif + kl = skal*9 + if (rad3(kl:kl) /= '/') then + if (rad3(kl:kl) /= ' ') then + nr = 10*(ichar(rad3(kl:kl))-ichar('0')) + else + nr = 0 + endif + kl = kl + 1 if (rad3(kl:kl) /= ' ') nr = nr + (ichar(rad3(kl:kl))-ichar('0')& - ) - else - kl = skal*9 - 2 - if (rad3(kl:kl) /= ' ') then - nr = 10*(ichar(rad3(kl:kl))-ichar('0')) - else - nr = 0 - endif - kl = kl + 1 - nr = nr + ichar(rad3(kl:kl)) - ichar('0') - endif - endif - if (expand) then - rewind (fil_2) - else - rewind (fil_1) - endif - else - slut = .TRUE. - endif - return - 99 continue - slut = .TRUE. - if (expand) then - close(fil_2) - else - close(fil_1) - endif - return - 100 format(a) - return - end subroutine adder + ) + else + kl = skal*9 - 2 + if (rad3(kl:kl) /= ' ') then + nr = 10*(ichar(rad3(kl:kl))-ichar('0')) + else + nr = 0 + endif + kl = kl + 1 + nr = nr + ichar(rad3(kl:kl)) - ichar('0') + endif + endif + if (expand) then + rewind (fil_2) + else + rewind (fil_1) + endif + else + slut = .TRUE. + endif + return + 99 continue + slut = .TRUE. + if (expand) then + close(fil_2) + else + close(fil_1) + endif + return + 100 format(a) + return + end subroutine adder diff --git a/src/appl/jjgen90/adder_I.f90 b/src/appl/jjgen90/adder_I.f90 index e1936e390..240faf7c8 100644 --- a/src/appl/jjgen90/adder_I.f90 +++ b/src/appl/jjgen90/adder_I.f90 @@ -1,13 +1,13 @@ - MODULE adder_I + MODULE adder_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE adder (CLOSED, MED, SLUT, ANEL, PAR, EXPAND) - LOGICAL, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - LOGICAL, DIMENSION(15,0:10) :: MED - LOGICAL, INTENT(OUT) :: SLUT - INTEGER, INTENT(OUT) :: ANEL - INTEGER, INTENT(OUT) :: PAR - LOGICAL, INTENT(IN) :: EXPAND - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE adder (CLOSED, MED, SLUT, ANEL, PAR, EXPAND) + LOGICAL, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + LOGICAL, DIMENSION(15,0:10) :: MED + LOGICAL, INTENT(OUT) :: SLUT + INTEGER, INTENT(OUT) :: ANEL + INTEGER, INTENT(OUT) :: PAR + LOGICAL, INTENT(IN) :: EXPAND + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/blanda.f90 b/src/appl/jjgen90/blanda.f90 index 845987b8b..56ab24a02 100644 --- a/src/appl/jjgen90/blanda.f90 +++ b/src/appl/jjgen90/blanda.f90 @@ -1,46 +1,46 @@ ! last edited Januar 2, 1997 subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, first) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + posl, lim, dubbel, first) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use slug_I - use gen_I + use slug_I + use gen_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer :: minj - integer :: maxj - integer :: skal - integer , intent(in) :: nmax - logical :: first - integer :: org(15,0:10) - integer :: low(15,0:10) - integer :: posn(110) - integer :: posl(110) - integer , intent(in) :: lim(15) - logical :: lock(15,0:10) - logical :: dubbel(15,0:10) + integer :: varmax + integer :: minj + integer :: maxj + integer :: skal + integer , intent(in) :: nmax + logical :: first + integer :: org(15,0:10) + integer :: low(15,0:10) + integer :: posn(110) + integer :: posl(110) + integer , intent(in) :: lim(15) + logical :: lock(15,0:10) + logical :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: antel, start - integer :: cf - integer , dimension(15,0:10,0:1) :: ansats - integer , dimension(15,0:10) :: varupp, varned + integer , dimension(15,0:10) :: antel, start + integer :: cf + integer , dimension(15,0:10,0:1) :: ansats + integer , dimension(15,0:10) :: varupp, varned integer :: an10, an20, an21, an30, an31, an32, an40, an41, an42, an43, k& , an50, an51, an52, an53, an54, an60, an61, an62, an63, an64, an65, & - an70, an71, an72, an73, an74, an75, an76 - integer , dimension(15,0:10) :: stopp + an70, an71, an72, an73, an74, an75, an76 + integer , dimension(15,0:10) :: stopp integer :: an80, an81, an82, an83, an84, an85, an86, an87, an90, an91, & an92, an93, an94, an95, an96, an97, an98, ana0, ana1, ana2, ana3, ana4& , ana5, ana6, ana7, ana8, ana9, plus21, plus31, plus32, plus41, plus42& @@ -49,10 +49,10 @@ subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & , plus82, plus83, plus84, plus85, plus86, plus87, plus91, plus92, & plus93, plus94, plus95, plus96, plus97, plus98, plusa1, plusa2, plusa3& , plusa4, plusa5, plusa6, plusa7, plusa8, plusa9, par0, par, ress, & - resl, i, j, antal - integer , dimension(15,0:10) :: steg - integer :: dum, ras1, ras3, elar, rasett, rastre - integer , dimension(15,0:10) :: ras + resl, i, j, antal + integer , dimension(15,0:10) :: steg + integer :: dum, ras1, ras3, elar, rasett, rastre + integer , dimension(15,0:10) :: ras integer :: plusba, plusca, plusda, plusea, plusfa, plusb1, plusb2, plusb3& , plusb4, plusb5, plusb6, plusb7, plusb8, plusb9, plusc1, plusc2, & plusc3, plusc4, plusc5, plusc6, plusc7, plusc8, plusc9, plusd1, plusd2& @@ -63,1602 +63,1602 @@ subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & anb7, anb8, anb9, anc0, anc1, anc2, anc3, anc4, anc5, anc6, anc7, anc8& , anc9, and0, and1, and2, and3, and4, and5, and6, and7, and8, and9, & ane0, ane1, ane2, ane3, ane4, ane5, ane6, ane7, ane8, ane9, anf0, anf1& - , anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 - logical :: finns, napp + , anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 + logical :: finns, napp !----------------------------------------------- - - cf = 0 - antal = 0 - par0 = 0 - finns = .FALSE. - do i = 1, nmax - do j = 0, min(10,i - 1) - if (dubbel(i,j)) then - steg(i,j) = -2 - else - steg(i,j) = -1 - endif - antal = antal + org(i,j) - par0 = mod(par0 + j*org(i,j),2) - end do - end do - if (nmax < 15) then - do i = nmax + 1, 15 - steg(i,:min(10,i-1)) = -1 - end do - endif + + cf = 0 + antal = 0 + par0 = 0 + finns = .FALSE. + do i = 1, nmax + do j = 0, min(10,i - 1) + if (dubbel(i,j)) then + steg(i,j) = -2 + else + steg(i,j) = -1 + endif + antal = antal + org(i,j) + par0 = mod(par0 + j*org(i,j),2) + end do + end do + if (nmax < 15) then + do i = nmax + 1, 15 + steg(i,:min(10,i-1)) = -1 + end do + endif ! 1s call slug (1, 0, varmax, varupp, varned, ansats, org, lock(1,0), dubbel, & - low, start(1,0), stopp(1,0)) - do an10 = start(1,0), stopp(1,0), steg(1,0) - antel(1,0) = an10 - if (antel(1,0)>antal .or. antel(1,0)antal .or. antel(1,0) antal) cycle - ansats(2,0,0) = an20 + dubbel, low, start(2,0), stopp(2,0)) + do an20 = start(2,0), stopp(2,0), steg(2,0) + antel(2,0) = an20 + antel(1,0) + if (antel(2,0) > antal) cycle + ansats(2,0,0) = an20 ! 2p call slug (2, 1, varmax, varupp, varned, ansats, org, lock(2,1), & - dubbel, low, start(2,1), stopp(2,1)) - do an21 = start(2,1), stopp(2,1), steg(2,1) - antel(2,1) = an21 + antel(2,0) - if (antel(2,1)>antal .or. antel(2,1)antal .or. antel(2,1) antal) cycle - ansats(3,0,0) = an30 + 0), dubbel, low, start(3,0), stopp(3,0)) + do an30 = start(3,0), stopp(3,0), steg(3,0) + antel(3,0) = an30 + antel(2,1) + if (antel(3,0) > antal) cycle + ansats(3,0,0) = an30 ! 3p call slug (3, 1, varmax, varupp, varned, ansats, org, lock& - (3,1), dubbel, low, start(3,1), stopp(3,1)) - do an31 = start(3,1), stopp(3,1), steg(3,1) - antel(3,1) = an31 + antel(3,0) - if (antel(3,1) > antal) cycle - do plus31 = min(an31,4), max(an31 - 2,0), -1 - ansats(3,1,1) = plus31 - ansats(3,1,0) = an31 - plus31 + (3,1), dubbel, low, start(3,1), stopp(3,1)) + do an31 = start(3,1), stopp(3,1), steg(3,1) + antel(3,1) = an31 + antel(3,0) + if (antel(3,1) > antal) cycle + do plus31 = min(an31,4), max(an31 - 2,0), -1 + ansats(3,1,1) = plus31 + ansats(3,1,0) = an31 - plus31 ! 3d call slug (3, 2, varmax, varupp, varned, ansats, org& - , lock(3,2), dubbel, low, start(3,2), stopp(3,2)) - do an32 = start(3,2), stopp(3,2), steg(3,2) - antel(3,2) = an32 + antel(3,1) + , lock(3,2), dubbel, low, start(3,2), stopp(3,2)) + do an32 = start(3,2), stopp(3,2), steg(3,2) + antel(3,2) = an32 + antel(3,1) if (antel(3,2)>antal .or. antel(3,2) antal) cycle - ansats(4,0,0) = an40 + 4,0), stopp(4,0)) + do an40 = start(4,0), stopp(4,0), steg(4,0) + antel(4,0) = an40 + antel(3,2) + if (antel(4,0) > antal) cycle + ansats(4,0,0) = an40 ! 4p call slug (4, 1, varmax, varupp, varned, & ansats, org, lock(4,1), dubbel, low, & - start(4,1), stopp(4,1)) - do an41 = start(4,1), stopp(4,1), steg(4,1) - antel(4,1) = an41 + antel(4,0) - if (antel(4,1) > antal) cycle + start(4,1), stopp(4,1)) + do an41 = start(4,1), stopp(4,1), steg(4,1) + antel(4,1) = an41 + antel(4,0) + if (antel(4,1) > antal) cycle do plus41 = min(an41,4), max(an41 - 2,0), & - -1 - ansats(4,1,1) = plus41 - ansats(4,1,0) = an41 - plus41 + -1 + ansats(4,1,1) = plus41 + ansats(4,1,0) = an41 - plus41 ! 4d call slug (4, 2, varmax, varupp, varned, & ansats, org, lock(4,2), dubbel, low, & - start(4,2), stopp(4,2)) - do an42 = start(4,2), stopp(4,2), steg(4,2) - antel(4,2) = an42 + antel(4,1) - if (antel(4,2) > antal) cycle + start(4,2), stopp(4,2)) + do an42 = start(4,2), stopp(4,2), steg(4,2) + antel(4,2) = an42 + antel(4,1) + if (antel(4,2) > antal) cycle do plus42 = min(an42,6), max(an42 - 4,0), & - -1 - ansats(4,2,1) = plus42 - ansats(4,2,0) = an42 - plus42 + -1 + ansats(4,2,1) = plus42 + ansats(4,2,0) = an42 - plus42 ! 4f call slug (4, 3, varmax, varupp, varned, & ansats, org, lock(4,3), dubbel, low, & - start(4,3), stopp(4,3)) - do an43 = start(4,3), stopp(4,3), steg(4,3) - antel(4,3) = an43 + antel(4,2) + start(4,3), stopp(4,3)) + do an43 = start(4,3), stopp(4,3), steg(4,3) + antel(4,3) = an43 + antel(4,2) if (antel(4,3)>antal .or. antel(4,3) antal) cycle - ansats(5,0,0) = an50 + start(5,0), stopp(5,0)) + do an50 = start(5,0), stopp(5,0), steg(5,0) + antel(5,0) = an50 + antel(4,3) + if (antel(5,0) > antal) cycle + ansats(5,0,0) = an50 ! 5p call slug (5, 1, varmax, varupp, varned, & ansats, org, lock(5,1), dubbel, low, & - start(5,1), stopp(5,1)) - do an51 = start(5,1), stopp(5,1), steg(5,1) - antel(5,1) = an51 + antel(5,0) - if (antel(5,1) > antal) cycle + start(5,1), stopp(5,1)) + do an51 = start(5,1), stopp(5,1), steg(5,1) + antel(5,1) = an51 + antel(5,0) + if (antel(5,1) > antal) cycle do plus51 = min(an51,4), max(an51 - 2,0), & - -1 - ansats(5,1,1) = plus51 - ansats(5,1,0) = an51 - plus51 + -1 + ansats(5,1,1) = plus51 + ansats(5,1,0) = an51 - plus51 ! 5d call slug (5, 2, varmax, varupp, varned, & ansats, org, lock(5,2), dubbel, low, & - start(5,2), stopp(5,2)) - do an52 = start(5,2), stopp(5,2), steg(5,2) - antel(5,2) = an52 + antel(5,1) - if (antel(5,2) > antal) cycle + start(5,2), stopp(5,2)) + do an52 = start(5,2), stopp(5,2), steg(5,2) + antel(5,2) = an52 + antel(5,1) + if (antel(5,2) > antal) cycle do plus52 = min(an52,6), max(an52 - 4,0), & - -1 - ansats(5,2,1) = plus52 - ansats(5,2,0) = an52 - plus52 - + -1 + ansats(5,2,1) = plus52 + ansats(5,2,0) = an52 - plus52 + ! 5f call slug (5, 3, varmax, varupp, varned, & ansats, org, lock(5,3), dubbel, low, & - start(5,3), stopp(5,3)) - do an53 = start(5,3), stopp(5,3), steg(5,3) - antel(5,3) = an53 + antel(5,2) - if (antel(5,3) > antal) cycle + start(5,3), stopp(5,3)) + do an53 = start(5,3), stopp(5,3), steg(5,3) + antel(5,3) = an53 + antel(5,2) + if (antel(5,3) > antal) cycle do plus53 = min(an53,8), max(an53 - 6,0), & - -1 - ansats(5,3,1) = plus53 - ansats(5,3,0) = an53 - plus53 + -1 + ansats(5,3,1) = plus53 + ansats(5,3,0) = an53 - plus53 ! 5g call slug (5, 4, varmax, varupp, varned, & ansats, org, lock(5,4), dubbel, low, & - start(5,4), stopp(5,4)) - do an54 = start(5,4), stopp(5,4), steg(5,4) - antel(5,4) = an54 + antel(5,3) + start(5,4), stopp(5,4)) + do an54 = start(5,4), stopp(5,4), steg(5,4) + antel(5,4) = an54 + antel(5,3) if (antel(5,4)>antal .or. antel(5,4)antal .or. ansats(5,4,1)>2) & - cycle - ansats(6,0,0) = an60 + cycle + ansats(6,0,0) = an60 ! 6p call slug (6, 1, varmax, varupp, varned, & ansats, org, lock(6,1), dubbel, low, & - start(6,1), stopp(6,1)) - do an61 = start(6,1), stopp(6,1), steg(6,1) - antel(6,1) = an61 + antel(6,0) - if (antel(6,1) > antal) cycle + start(6,1), stopp(6,1)) + do an61 = start(6,1), stopp(6,1), steg(6,1) + antel(6,1) = an61 + antel(6,0) + if (antel(6,1) > antal) cycle do plus61 = min(an61,4), max(an61 - 2,0), & - -1 - ansats(6,1,1) = plus61 - ansats(6,1,0) = an61 - plus61 + -1 + ansats(6,1,1) = plus61 + ansats(6,1,0) = an61 - plus61 ! 6d call slug (6, 2, varmax, varupp, varned, & ansats, org, lock(6,2), dubbel, low, & - start(6,2), stopp(6,2)) - do an62 = start(6,2), stopp(6,2), steg(6,2) - antel(6,2) = an62 + antel(6,1) - if (antel(6,2) > antal) cycle + start(6,2), stopp(6,2)) + do an62 = start(6,2), stopp(6,2), steg(6,2) + antel(6,2) = an62 + antel(6,1) + if (antel(6,2) > antal) cycle do plus62 = min(an62,6), max(an62 - 4,0), & - -1 - ansats(6,2,1) = plus62 - ansats(6,2,0) = an62 - plus62 + -1 + ansats(6,2,1) = plus62 + ansats(6,2,0) = an62 - plus62 ! 6f call slug (6, 3, varmax, varupp, varned, & ansats, org, lock(6,3), dubbel, low, & - start(6,3), stopp(6,3)) - do an63 = start(6,3), stopp(6,3), steg(6,3) - antel(6,3) = an63 + antel(6,2) - if (antel(6,3) > antal) cycle + start(6,3), stopp(6,3)) + do an63 = start(6,3), stopp(6,3), steg(6,3) + antel(6,3) = an63 + antel(6,2) + if (antel(6,3) > antal) cycle do plus63 = min(an63,8), max(an63 - 6,0), & - -1 - ansats(6,3,1) = plus63 - ansats(6,3,0) = an63 - plus63 + -1 + ansats(6,3,1) = plus63 + ansats(6,3,0) = an63 - plus63 ! 6g call slug (6, 4, varmax, varupp, varned, & ansats, org, lock(6,4), dubbel, low, & - start(6,4), stopp(6,4)) - do an64 = start(6,4), stopp(6,4), steg(6,4) - antel(6,4) = an64 + antel(6,3) - if (antel(6,4) > antal) cycle + start(6,4), stopp(6,4)) + do an64 = start(6,4), stopp(6,4), steg(6,4) + antel(6,4) = an64 + antel(6,3) + if (antel(6,4) > antal) cycle do plus64 = min(an64,10), max(an64 - 8,0), & - -1 - ansats(6,4,1) = plus64 - ansats(6,4,0) = an64 - plus64 + -1 + ansats(6,4,1) = plus64 + ansats(6,4,0) = an64 - plus64 ! 6h call slug (6, 5, varmax, varupp, varned, & ansats, org, lock(6,5), dubbel, low, & - start(6,5), stopp(6,5)) - do an65 = start(6,5), stopp(6,5), steg(6,5) - antel(6,5) = an65 + antel(6,4) + start(6,5), stopp(6,5)) + do an65 = start(6,5), stopp(6,5), steg(6,5) + antel(6,5) = an65 + antel(6,4) if (.not.(antel(6,5)<=antal .and. ansats(6,& 4,1)<=2 .and. antel(6,5)>=lim(6))) & - cycle + cycle do plus65 = min(an65,12), max(an65 - 10,0)& - , -1 - ansats(6,5,1) = plus65 - ansats(6,5,0) = an65 - plus65 + , -1 + ansats(6,5,1) = plus65 + ansats(6,5,0) = an65 - plus65 ! 7s call slug (7, 0, varmax, varupp, varned, & ansats, org, lock(7,0), dubbel, low, & - start(7,0), stopp(7,0)) - do an70 = start(7,0), stopp(7,0), steg(7,0) - antel(7,0) = an70 + antel(6,5) + start(7,0), stopp(7,0)) + do an70 = start(7,0), stopp(7,0), steg(7,0) + antel(7,0) = an70 + antel(6,5) if (.not.(antel(7,0)<=antal .and. ansats(6,& - 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle - ansats(7,0,0) = an70 + 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle + ansats(7,0,0) = an70 ! 7p call slug (7, 1, varmax, varupp, varned, & ansats, org, lock(7,1), dubbel, low, & - start(7,1), stopp(7,1)) - do an71 = start(7,1), stopp(7,1), steg(7,1) - antel(7,1) = an71 + antel(7,0) - if (antel(7,1) > antal) cycle + start(7,1), stopp(7,1)) + do an71 = start(7,1), stopp(7,1), steg(7,1) + antel(7,1) = an71 + antel(7,0) + if (antel(7,1) > antal) cycle do plus71 = min(an71,4), max(an71 - 2,0), & - -1 - ansats(7,1,1) = plus71 - ansats(7,1,0) = an71 - plus71 + -1 + ansats(7,1,1) = plus71 + ansats(7,1,0) = an71 - plus71 ! 7d call slug (7, 2, varmax, varupp, varned, & ansats, org, lock(7,2), dubbel, low, & - start(7,2), stopp(7,2)) - do an72 = start(7,2), stopp(7,2), steg(7,2) - antel(7,2) = an72 + antel(7,1) - if (antel(7,2) > antal) cycle + start(7,2), stopp(7,2)) + do an72 = start(7,2), stopp(7,2), steg(7,2) + antel(7,2) = an72 + antel(7,1) + if (antel(7,2) > antal) cycle do plus72 = min(an72,6), max(an72 - 4,0), & - -1 - ansats(7,2,1) = plus72 - ansats(7,2,0) = an72 - plus72 + -1 + ansats(7,2,1) = plus72 + ansats(7,2,0) = an72 - plus72 ! 7f call slug (7, 3, varmax, varupp, varned, & ansats, org, lock(7,3), dubbel, low, & - start(7,3), stopp(7,3)) - do an73 = start(7,3), stopp(7,3), steg(7,3) - antel(7,3) = an73 + antel(7,2) - if (antel(7,3) > antal) cycle + start(7,3), stopp(7,3)) + do an73 = start(7,3), stopp(7,3), steg(7,3) + antel(7,3) = an73 + antel(7,2) + if (antel(7,3) > antal) cycle do plus73 = min(an73,8), max(an73 - 6,0), & - -1 - ansats(7,3,1) = plus73 - ansats(7,3,0) = an73 - plus73 + -1 + ansats(7,3,1) = plus73 + ansats(7,3,0) = an73 - plus73 ! 7g call slug (7, 4, varmax, varupp, varned, & ansats, org, lock(7,4), dubbel, low, & - start(7,4), stopp(7,4)) - do an74 = start(7,4), stopp(7,4), steg(7,4) - antel(7,4) = an74 + antel(7,3) - if (antel(7,4) > antal) cycle + start(7,4), stopp(7,4)) + do an74 = start(7,4), stopp(7,4), steg(7,4) + antel(7,4) = an74 + antel(7,3) + if (antel(7,4) > antal) cycle do plus74 = min(an74,10), max(an74 - 8,0), & - -1 - ansats(7,4,1) = plus74 - ansats(7,4,0) = an74 - plus74 + -1 + ansats(7,4,1) = plus74 + ansats(7,4,0) = an74 - plus74 ! 7h call slug (7, 5, varmax, varupp, varned, & ansats, org, lock(7,5), dubbel, low, & - start(7,5), stopp(7,5)) - do an75 = start(7,5), stopp(7,5), steg(7,5) - antel(7,5) = an75 + antel(7,4) + start(7,5), stopp(7,5)) + do an75 = start(7,5), stopp(7,5), steg(7,5) + antel(7,5) = an75 + antel(7,4) if (antel(7,5)>antal .or. ansats(7,4,1)>2) & - cycle + cycle do plus75 = min(an75,12), max(an75 - 10,0)& - , -1 - ansats(7,5,1) = plus75 - ansats(7,5,0) = an75 - plus75 + , -1 + ansats(7,5,1) = plus75 + ansats(7,5,0) = an75 - plus75 ! 7i call slug (7, 6, varmax, varupp, varned, & ansats, org, lock(7,6), dubbel, low, & - start(7,6), stopp(7,6)) - do an76 = start(7,6), stopp(7,6), steg(7,6) - antel(7,6) = an76 + antel(7,5) + start(7,6), stopp(7,6)) + do an76 = start(7,6), stopp(7,6), steg(7,6) + antel(7,6) = an76 + antel(7,5) if (.not.(antel(7,6)<=antal .and. ansats(7,& 5,1)<=2 .and. ansats(7,5,0)<=2 .and. & - antel(7,6)>=lim(7))) cycle + antel(7,6)>=lim(7))) cycle do plus76 = min(an76,14), max(an76 - 12,0)& - , -1 - ansats(7,6,1) = plus76 - ansats(7,6,0) = an76 - plus76 + , -1 + ansats(7,6,1) = plus76 + ansats(7,6,0) = an76 - plus76 ! 8s call slug (8, 0, varmax, varupp, varned, & ansats, org, lock(8,0), dubbel, low, & - start(8,0), stopp(8,0)) - do an80 = start(8,0), stopp(8,0), steg(8,0) - antel(8,0) = an80 + antel(7,6) + start(8,0), stopp(8,0)) + do an80 = start(8,0), stopp(8,0), steg(8,0) + antel(8,0) = an80 + antel(7,6) if (.not.(antel(8,0)<=antal .and. ansats(7,& - 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle - ansats(8,0,0) = an80 + 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle + ansats(8,0,0) = an80 ! 8p call slug (8, 1, varmax, varupp, varned, & ansats, org, lock(8,1), dubbel, low, & - start(8,1), stopp(8,1)) - do an81 = start(8,1), stopp(8,1), steg(8,1) - antel(8,1) = an81 + antel(8,0) - if (antel(8,1) > antal) cycle + start(8,1), stopp(8,1)) + do an81 = start(8,1), stopp(8,1), steg(8,1) + antel(8,1) = an81 + antel(8,0) + if (antel(8,1) > antal) cycle do plus81 = min(an81,4), max(an81 - 2,0), & - -1 - ansats(8,1,1) = plus81 - ansats(8,1,0) = an81 - plus81 + -1 + ansats(8,1,1) = plus81 + ansats(8,1,0) = an81 - plus81 ! 8d call slug (8, 2, varmax, varupp, varned, & ansats, org, lock(8,2), dubbel, low, & - start(8,2), stopp(8,2)) - do an82 = start(8,2), stopp(8,2), steg(8,2) - antel(8,2) = an82 + antel(8,1) - if (antel(8,2) > antal) cycle + start(8,2), stopp(8,2)) + do an82 = start(8,2), stopp(8,2), steg(8,2) + antel(8,2) = an82 + antel(8,1) + if (antel(8,2) > antal) cycle do plus82 = min(an82,6), max(an82 - 4,0), & - -1 - ansats(8,2,1) = plus82 - ansats(8,2,0) = an82 - plus82 + -1 + ansats(8,2,1) = plus82 + ansats(8,2,0) = an82 - plus82 ! 8f call slug (8, 3, varmax, varupp, varned, & ansats, org, lock(8,3), dubbel, low, & - start(8,3), stopp(8,3)) - do an83 = start(8,3), stopp(8,3), steg(8,3) - antel(8,3) = an83 + antel(8,2) - if (antel(8,3) > antal) cycle + start(8,3), stopp(8,3)) + do an83 = start(8,3), stopp(8,3), steg(8,3) + antel(8,3) = an83 + antel(8,2) + if (antel(8,3) > antal) cycle do plus83 = min(an83,8), max(an83 - 6,0), & - -1 - ansats(8,3,1) = plus83 - ansats(8,3,0) = an83 - plus83 + -1 + ansats(8,3,1) = plus83 + ansats(8,3,0) = an83 - plus83 ! 8g call slug (8, 4, varmax, varupp, varned, & ansats, org, lock(8,4), dubbel, low, & - start(8,4), stopp(8,4)) - - do an84 = start(8,4), stopp(8,4), steg(8,4) - antel(8,4) = an84 + antel(8,3) - if (antel(8,4) > antal) cycle + start(8,4), stopp(8,4)) + + do an84 = start(8,4), stopp(8,4), steg(8,4) + antel(8,4) = an84 + antel(8,3) + if (antel(8,4) > antal) cycle do plus84 = min(an84,10), max(an84 - 8,0), & - -1 - ansats(8,4,1) = plus84 - ansats(8,4,0) = an84 - plus84 + -1 + ansats(8,4,1) = plus84 + ansats(8,4,0) = an84 - plus84 ! 8h call slug (8, 5, varmax, varupp, varned, & ansats, org, lock(8,5), dubbel, low, & - start(8,5), stopp(8,5)) - do an85 = start(8,5), stopp(8,5), steg(8,5) - antel(8,5) = an85 + antel(8,4) + start(8,5), stopp(8,5)) + do an85 = start(8,5), stopp(8,5), steg(8,5) + antel(8,5) = an85 + antel(8,4) if (antel(8,5)>antal .or. ansats(8,4,1)>2) & - cycle + cycle do plus85 = min(an85,12), max(an85 - 10,0)& - , -1 - ansats(8,5,1) = plus85 - ansats(8,5,0) = an85 - plus85 + , -1 + ansats(8,5,1) = plus85 + ansats(8,5,0) = an85 - plus85 ! 8i call slug (8, 6, varmax, varupp, varned, & ansats, org, lock(8,6), dubbel, low, & - start(8,6), stopp(8,6)) - do an86 = start(8,6), stopp(8,6), steg(8,6) - antel(8,6) = an86 + antel(8,5) + start(8,6), stopp(8,6)) + do an86 = start(8,6), stopp(8,6), steg(8,6) + antel(8,6) = an86 + antel(8,5) if (.not.(antel(8,6)<=antal .and. ansats(8,& - 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle do plus86 = min(an86,14), max(an86 - 12,0)& - , -1 - ansats(8,6,1) = plus86 - ansats(8,6,0) = an86 - plus86 + , -1 + ansats(8,6,1) = plus86 + ansats(8,6,0) = an86 - plus86 ! 8k call slug (8, 7, varmax, varupp, varned, & ansats, org, lock(8,7), dubbel, low, & - start(8,7), stopp(8,7)) - do an87 = start(8,7), stopp(8,7), steg(8,7) - antel(8,7) = an87 + antel(8,6) + start(8,7), stopp(8,7)) + do an87 = start(8,7), stopp(8,7), steg(8,7) + antel(8,7) = an87 + antel(8,6) if (.not.(antel(8,7)<=antal .and. ansats(8,& 6,1)<=2 .and. ansats(8,6,0)<=2 .and. & - antel(8,7)>=lim(8))) cycle + antel(8,7)>=lim(8))) cycle do plus87 = min(an87,16), max(an87 - 14,0)& - , -1 - ansats(8,7,1) = plus87 - ansats(8,7,0) = an87 - plus87 + , -1 + ansats(8,7,1) = plus87 + ansats(8,7,0) = an87 - plus87 ! 9s call slug (9, 0, varmax, varupp, varned, & ansats, org, lock(9,0), dubbel, low, & - start(9,0), stopp(9,0)) - do an90 = start(9,0), stopp(9,0), steg(9,0) - antel(9,0) = an90 + antel(8,7) + start(9,0), stopp(9,0)) + do an90 = start(9,0), stopp(9,0), steg(9,0) + antel(9,0) = an90 + antel(8,7) if (.not.(antel(9,0)<=antal .and. ansats(8,& - 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle - ansats(9,0,0) = an90 + 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle + ansats(9,0,0) = an90 ! 9p call slug (9, 1, varmax, varupp, varned, & ansats, org, lock(9,1), dubbel, low, & - start(9,1), stopp(9,1)) - do an91 = start(9,1), stopp(9,1), steg(9,1) - antel(9,1) = an91 + antel(9,0) - if (antel(9,1) > antal) cycle + start(9,1), stopp(9,1)) + do an91 = start(9,1), stopp(9,1), steg(9,1) + antel(9,1) = an91 + antel(9,0) + if (antel(9,1) > antal) cycle do plus91 = min(an91,4), max(an91 - 2,0), & - -1 - ansats(9,1,1) = plus91 - ansats(9,1,0) = an91 - plus91 + -1 + ansats(9,1,1) = plus91 + ansats(9,1,0) = an91 - plus91 ! 9d call slug (9, 2, varmax, varupp, varned, & ansats, org, lock(9,2), dubbel, low, & - start(9,2), stopp(9,2)) - do an92 = start(9,2), stopp(9,2), steg(9,2) - antel(9,2) = an92 + antel(9,1) - if (antel(9,2) > antal) cycle + start(9,2), stopp(9,2)) + do an92 = start(9,2), stopp(9,2), steg(9,2) + antel(9,2) = an92 + antel(9,1) + if (antel(9,2) > antal) cycle do plus92 = min(an92,6), max(an92 - 4,0), & - -1 - ansats(9,2,1) = plus92 - ansats(9,2,0) = an92 - plus92 + -1 + ansats(9,2,1) = plus92 + ansats(9,2,0) = an92 - plus92 ! 9f call slug (9, 3, varmax, varupp, varned, & ansats, org, lock(9,3), dubbel, low, & - start(9,3), stopp(9,3)) - do an93 = start(9,3), stopp(9,3), steg(9,3) - antel(9,3) = an93 + antel(9,2) - if (antel(9,3) > antal) cycle + start(9,3), stopp(9,3)) + do an93 = start(9,3), stopp(9,3), steg(9,3) + antel(9,3) = an93 + antel(9,2) + if (antel(9,3) > antal) cycle do plus93 = min(an93,8), max(an93 - 6,0), & - -1 - ansats(9,3,1) = plus93 - ansats(9,3,0) = an93 - plus93 + -1 + ansats(9,3,1) = plus93 + ansats(9,3,0) = an93 - plus93 ! 9g call slug (9, 4, varmax, varupp, varned, & ansats, org, lock(9,4), dubbel, low, & - start(9,4), stopp(9,4)) - do an94 = start(9,4), stopp(9,4), steg(9,4) - antel(9,4) = an94 + antel(9,3) - if (antel(9,4) > antal) cycle + start(9,4), stopp(9,4)) + do an94 = start(9,4), stopp(9,4), steg(9,4) + antel(9,4) = an94 + antel(9,3) + if (antel(9,4) > antal) cycle do plus94 = min(an94,10), max(an94 - 8,0), & - -1 - ansats(9,4,1) = plus94 - ansats(9,4,0) = an94 - plus94 + -1 + ansats(9,4,1) = plus94 + ansats(9,4,0) = an94 - plus94 ! 9h call slug (9, 5, varmax, varupp, varned, & ansats, org, lock(9,5), dubbel, low, & - start(9,5), stopp(9,5)) - do an95 = start(9,5), stopp(9,5), steg(9,5) - antel(9,5) = an95 + antel(9,4) + start(9,5), stopp(9,5)) + do an95 = start(9,5), stopp(9,5), steg(9,5) + antel(9,5) = an95 + antel(9,4) if (antel(9,5)>antal .or. ansats(9,4,1)>2) & - cycle + cycle do plus95 = min(an95,12), max(an95 - 10,0)& - , -1 - ansats(9,5,1) = plus95 - ansats(9,5,0) = an95 - plus95 + , -1 + ansats(9,5,1) = plus95 + ansats(9,5,0) = an95 - plus95 ! 9i call slug (9, 6, varmax, varupp, varned, & ansats, org, lock(9,6), dubbel, low, & - start(9,6), stopp(9,6)) - do an96 = start(9,6), stopp(9,6), steg(9,6) - antel(9,6) = an96 + antel(9,5) + start(9,6), stopp(9,6)) + do an96 = start(9,6), stopp(9,6), steg(9,6) + antel(9,6) = an96 + antel(9,5) if (.not.(antel(9,6)<=antal .and. ansats(9,& - 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle do plus96 = min(an96,14), max(an96 - 12,0)& - , -1 - ansats(9,6,1) = plus96 - ansats(9,6,0) = an96 - plus96 + , -1 + ansats(9,6,1) = plus96 + ansats(9,6,0) = an96 - plus96 ! 9k call slug (9, 7, varmax, varupp, varned, & ansats, org, lock(9,7), dubbel, low, & - start(9,7), stopp(9,7)) - do an97 = start(9,7), stopp(9,7), steg(9,7) - antel(9,7) = an97 + antel(9,6) + start(9,7), stopp(9,7)) + do an97 = start(9,7), stopp(9,7), steg(9,7) + antel(9,7) = an97 + antel(9,6) if (.not.(antel(9,7)<=antal .and. ansats(9,& - 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle + 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle do plus97 = min(an97,16), max(an97 - 14,0)& - , -1 - ansats(9,7,1) = plus97 - ansats(9,7,0) = an97 - plus97 + , -1 + ansats(9,7,1) = plus97 + ansats(9,7,0) = an97 - plus97 ! 9l call slug (9, 8, varmax, varupp, varned, & ansats, org, lock(9,8), dubbel, low, & - start(9,8), stopp(9,8)) - do an98 = start(9,8), stopp(9,8), steg(9,8) - antel(9,8) = an98 + antel(9,7) + start(9,8), stopp(9,8)) + do an98 = start(9,8), stopp(9,8), steg(9,8) + antel(9,8) = an98 + antel(9,7) if (.not.(antel(9,8)<=antal .and. ansats(9,& 7,1)<=2 .and. ansats(9,7,0)<=2 .and. & - antel(9,8)>=lim(9))) cycle + antel(9,8)>=lim(9))) cycle do plus98 = min(an98,18), max(an98 - 16,0)& - , -1 - ansats(9,8,1) = plus98 - ansats(9,8,0) = an98 - plus98 + , -1 + ansats(9,8,1) = plus98 + ansats(9,8,0) = an98 - plus98 ! 10s call slug (10, 0, varmax, varupp, varned, & ansats, org, lock(10,0), dubbel, low, & - start(10,0), stopp(10,0)) + start(10,0), stopp(10,0)) do ana0 = start(10,0), stopp(10,0), steg(10& - ,0) - antel(10,0) = ana0 + antel(9,8) + ,0) + antel(10,0) = ana0 + antel(9,8) if (.not.(antel(10,0)<=antal .and. ansats(9& - ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle - ansats(10,0,0) = ana0 + ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle + ansats(10,0,0) = ana0 ! 10p call slug (10, 1, varmax, varupp, varned, & ansats, org, lock(10,1), dubbel, low, & - start(10,1), stopp(10,1)) + start(10,1), stopp(10,1)) do ana1 = start(10,1), stopp(10,1), steg(10& - ,1) - antel(10,1) = ana1 + antel(10,0) - if (antel(10,1) > antal) cycle + ,1) + antel(10,1) = ana1 + antel(10,0) + if (antel(10,1) > antal) cycle do plusa1 = min(ana1,4), max(ana1 - 2,0), & - -1 - ansats(10,1,1) = plusa1 - ansats(10,1,0) = ana1 - plusa1 + -1 + ansats(10,1,1) = plusa1 + ansats(10,1,0) = ana1 - plusa1 ! 10d call slug (10, 2, varmax, varupp, varned, & ansats, org, lock(10,2), dubbel, low, & - start(10,2), stopp(10,2)) + start(10,2), stopp(10,2)) do ana2 = start(10,2), stopp(10,2), steg(10& - ,2) - antel(10,2) = ana2 + antel(10,1) - if (antel(10,2) > antal) cycle + ,2) + antel(10,2) = ana2 + antel(10,1) + if (antel(10,2) > antal) cycle do plusa2 = min(ana2,6), max(ana2 - 4,0), & - -1 - ansats(10,2,1) = plusa2 - ansats(10,2,0) = ana2 - plusa2 + -1 + ansats(10,2,1) = plusa2 + ansats(10,2,0) = ana2 - plusa2 ! 10f call slug (10, 3, varmax, varupp, varned, & ansats, org, lock(10,3), dubbel, low, & - start(10,3), stopp(10,3)) + start(10,3), stopp(10,3)) do ana3 = start(10,3), stopp(10,3), steg(10& - ,3) - antel(10,3) = ana3 + antel(10,2) - if (antel(10,3) > antal) cycle + ,3) + antel(10,3) = ana3 + antel(10,2) + if (antel(10,3) > antal) cycle do plusa3 = min(ana3,8), max(ana3 - 6,0), & - -1 - ansats(10,3,1) = plusa3 - ansats(10,3,0) = ana3 - plusa3 + -1 + ansats(10,3,1) = plusa3 + ansats(10,3,0) = ana3 - plusa3 ! 10g call slug (10, 4, varmax, varupp, varned, & ansats, org, lock(10,4), dubbel, low, & - start(10,4), stopp(10,4)) + start(10,4), stopp(10,4)) do ana4 = start(10,4), stopp(10,4), steg(10& - ,4) - antel(10,4) = ana4 + antel(10,3) - if (antel(10,4) > antal) cycle + ,4) + antel(10,4) = ana4 + antel(10,3) + if (antel(10,4) > antal) cycle do plusa4 = min(ana4,10), max(ana4 - 8,0), & - -1 - ansats(10,4,1) = plusa4 - ansats(10,4,0) = ana4 - plusa4 + -1 + ansats(10,4,1) = plusa4 + ansats(10,4,0) = ana4 - plusa4 ! 10h call slug (10, 5, varmax, varupp, varned, & ansats, org, lock(10,5), dubbel, low, & - start(10,5), stopp(10,5)) + start(10,5), stopp(10,5)) do ana5 = start(10,5), stopp(10,5), steg(10& - ,5) - antel(10,5) = ana5 + antel(10,4) + ,5) + antel(10,5) = ana5 + antel(10,4) if (antel(10,5)>antal .or. ansats(10,4,1)>2& - ) cycle + ) cycle do plusa5 = min(ana5,12), max(ana5 - 10,0)& - , -1 - ansats(10,5,1) = plusa5 - ansats(10,5,0) = ana5 - plusa5 + , -1 + ansats(10,5,1) = plusa5 + ansats(10,5,0) = ana5 - plusa5 ! 10i call slug (10, 6, varmax, varupp, varned, & ansats, org, lock(10,6), dubbel, low, & - start(10,6), stopp(10,6)) + start(10,6), stopp(10,6)) do ana6 = start(10,6), stopp(10,6), steg(10& - ,6) - antel(10,6) = ana6 + antel(10,5) + ,6) + antel(10,6) = ana6 + antel(10,5) if (.not.(antel(10,6)<=antal .and. ansats(& 10,5,1)<=2 .and. ansats(10,5,0)<=2)) & - cycle + cycle do plusa6 = min(ana6,14), max(ana6 - 12,0)& - , -1 - ansats(10,6,1) = plusa6 - ansats(10,6,0) = ana6 - plusa6 + , -1 + ansats(10,6,1) = plusa6 + ansats(10,6,0) = ana6 - plusa6 ! 10k call slug (10, 7, varmax, varupp, varned, & ansats, org, lock(10,7), dubbel, low, & - start(10,7), stopp(10,7)) + start(10,7), stopp(10,7)) do ana7 = start(10,7), stopp(10,7), steg(10& - ,7) - antel(10,7) = ana7 + antel(10,6) + ,7) + antel(10,7) = ana7 + antel(10,6) if (.not.(antel(10,7)<=antal .and. ansats(& 10,6,1)<=2 .and. ansats(10,6,0)<=2)) & - cycle + cycle do plusa7 = min(ana7,16), max(ana7 - 14,0)& - , -1 - ansats(10,7,1) = plusa7 - ansats(10,7,0) = ana7 - plusa7 + , -1 + ansats(10,7,1) = plusa7 + ansats(10,7,0) = ana7 - plusa7 ! 10l call slug (10, 8, varmax, varupp, varned, & ansats, org, lock(10,8), dubbel, low, & - start(10,8), stopp(10,8)) + start(10,8), stopp(10,8)) do ana8 = start(10,8), stopp(10,8), steg(10& - ,8) - antel(10,8) = ana8 + antel(10,7) + ,8) + antel(10,8) = ana8 + antel(10,7) if (.not.(antel(10,8)<=antal .and. ansats(& 10,7,1)<=2 .and. ansats(10,7,0)<=2)) & - cycle + cycle do plusa8 = min(ana8,18), max(ana8 - 16,0)& - , -1 - ansats(10,8,1) = plusa8 - ansats(10,8,0) = ana8 - plusa8 + , -1 + ansats(10,8,1) = plusa8 + ansats(10,8,0) = ana8 - plusa8 ! 10m call slug (10, 9, varmax, varupp, varned, & ansats, org, lock(10,9), dubbel, low, & - start(10,9), stopp(10,9)) + start(10,9), stopp(10,9)) do ana9 = start(10,9), stopp(10,9), steg(10& - ,9) - antel(10,9) = ana9 + antel(10,8) + ,9) + antel(10,9) = ana9 + antel(10,8) if (.not.(antel(10,9)<=antal .and. ansats(& 10,8,1)<=2 .and. ansats(10,8,0)<=2& - .and. antel(10,9)>=lim(10))) cycle + .and. antel(10,9)>=lim(10))) cycle do plusa9 = min(ana9,20), max(ana9 - 18,0)& - , -1 - ansats(10,9,1) = plusa9 - ansats(10,9,0) = ana9 - plusa9 + , -1 + ansats(10,9,1) = plusa9 + ansats(10,9,0) = ana9 - plusa9 ! 11s call slug (11, 0, varmax, varupp, varned, & ansats, org, lock(11,0), dubbel, low, & - start(11,0), stopp(11,0)) + start(11,0), stopp(11,0)) do anb0 = start(11,0), stopp(11,0), steg(11& - ,0) - antel(11,0) = anb0 + antel(10,9) + ,0) + antel(11,0) = anb0 + antel(10,9) if (.not.(antel(11,0)<=antal .and. ansats(& 10,9,1)<=2 .and. ansats(10,9,0)<=2)) & - cycle - ansats(11,0,0) = anb0 + cycle + ansats(11,0,0) = anb0 ! 11p call slug (11, 1, varmax, varupp, varned, & ansats, org, lock(11,1), dubbel, low, & - start(11,1), stopp(11,1)) + start(11,1), stopp(11,1)) do anb1 = start(11,1), stopp(11,1), steg(11& - ,1) - antel(11,1) = anb1 + antel(11,0) - if (antel(11,1) > antal) cycle + ,1) + antel(11,1) = anb1 + antel(11,0) + if (antel(11,1) > antal) cycle do plusb1 = min(anb1,4), max(anb1 - 2,0), & - -1 - ansats(11,1,1) = plusb1 - ansats(11,1,0) = anb1 - plusb1 + -1 + ansats(11,1,1) = plusb1 + ansats(11,1,0) = anb1 - plusb1 ! 11d call slug (11, 2, varmax, varupp, varned, & ansats, org, lock(11,2), dubbel, low, & - start(11,2), stopp(11,2)) + start(11,2), stopp(11,2)) do anb2 = start(11,2), stopp(11,2), steg(11& - ,2) - antel(11,2) = anb2 + antel(11,1) - if (antel(11,2) > antal) cycle + ,2) + antel(11,2) = anb2 + antel(11,1) + if (antel(11,2) > antal) cycle do plusb2 = min(anb2,6), max(anb2 - 4,0), & - -1 - ansats(11,2,1) = plusb2 - ansats(11,2,0) = anb2 - plusb2 + -1 + ansats(11,2,1) = plusb2 + ansats(11,2,0) = anb2 - plusb2 ! 11f call slug (11, 3, varmax, varupp, varned, & ansats, org, lock(11,3), dubbel, low, & - start(11,3), stopp(11,3)) + start(11,3), stopp(11,3)) do anb3 = start(11,3), stopp(11,3), steg(11& - ,3) - antel(11,3) = anb3 + antel(11,2) - if (antel(11,3) > antal) cycle + ,3) + antel(11,3) = anb3 + antel(11,2) + if (antel(11,3) > antal) cycle do plusb3 = min(anb3,8), max(anb3 - 6,0), & - -1 - ansats(11,3,1) = plusb3 - ansats(11,3,0) = anb3 - plusb3 + -1 + ansats(11,3,1) = plusb3 + ansats(11,3,0) = anb3 - plusb3 ! 11g call slug (11, 4, varmax, varupp, varned, & ansats, org, lock(11,4), dubbel, low, & - start(11,4), stopp(11,4)) + start(11,4), stopp(11,4)) do anb4 = start(11,4), stopp(11,4), steg(11& - ,4) - antel(11,4) = anb4 + antel(11,3) - if (antel(11,4) > antal) cycle + ,4) + antel(11,4) = anb4 + antel(11,3) + if (antel(11,4) > antal) cycle do plusb4 = min(anb4,10), max(anb4 - 8,0), & - -1 - ansats(11,4,1) = plusb4 - ansats(11,4,0) = anb4 - plusb4 + -1 + ansats(11,4,1) = plusb4 + ansats(11,4,0) = anb4 - plusb4 ! 11h call slug (11, 5, varmax, varupp, varned, & ansats, org, lock(11,5), dubbel, low, & - start(11,5), stopp(11,5)) + start(11,5), stopp(11,5)) do anb5 = start(11,5), stopp(11,5), steg(11& - ,5) - antel(11,5) = anb5 + antel(11,4) + ,5) + antel(11,5) = anb5 + antel(11,4) if (antel(11,5)>antal .or. ansats(11,4,1)>2& - ) cycle + ) cycle do plusb5 = min(anb5,12), max(anb5 - 10,0)& - , -1 - ansats(11,5,1) = plusb5 - ansats(11,5,0) = anb5 - plusb5 + , -1 + ansats(11,5,1) = plusb5 + ansats(11,5,0) = anb5 - plusb5 ! 11i call slug (11, 6, varmax, varupp, varned, & ansats, org, lock(11,6), dubbel, low, & - start(11,6), stopp(11,6)) + start(11,6), stopp(11,6)) do anb6 = start(11,6), stopp(11,6), steg(11& - ,6) - antel(11,6) = anb6 + antel(11,5) + ,6) + antel(11,6) = anb6 + antel(11,5) if (.not.(antel(11,6)<=antal .and. ansats(& 11,5,1)<=2 .and. ansats(11,5,0)<=2)) & - cycle + cycle do plusb6 = min(anb6,14), max(anb6 - 12,0)& - , -1 - ansats(11,6,1) = plusb6 - ansats(11,6,0) = anb6 - plusb6 + , -1 + ansats(11,6,1) = plusb6 + ansats(11,6,0) = anb6 - plusb6 ! 11k call slug (11, 7, varmax, varupp, varned, & ansats, org, lock(11,7), dubbel, low, & - start(11,7), stopp(11,7)) + start(11,7), stopp(11,7)) do anb7 = start(11,7), stopp(11,7), steg(11& - ,7) - antel(11,7) = anb7 + antel(11,6) + ,7) + antel(11,7) = anb7 + antel(11,6) if (.not.(antel(11,7)<=antal .and. ansats(& 11,6,1)<=2 .and. ansats(11,6,0)<=2)) & - cycle + cycle do plusb7 = min(anb7,16), max(anb7 - 14,0)& - , -1 - ansats(11,7,1) = plusb7 - ansats(11,7,0) = anb7 - plusb7 + , -1 + ansats(11,7,1) = plusb7 + ansats(11,7,0) = anb7 - plusb7 ! 11l call slug (11, 8, varmax, varupp, varned, & ansats, org, lock(11,8), dubbel, low, & - start(11,8), stopp(11,8)) + start(11,8), stopp(11,8)) do anb8 = start(11,8), stopp(11,8), steg(11& - ,8) - antel(11,8) = anb8 + antel(11,7) + ,8) + antel(11,8) = anb8 + antel(11,7) if (.not.(antel(11,8)<=antal .and. ansats(& 11,7,1)<=2 .and. ansats(11,7,0)<=2)) & - cycle + cycle do plusb8 = min(anb8,18), max(anb8 - 16,0)& - , -1 - ansats(11,8,1) = plusb8 - ansats(11,8,0) = anb8 - plusb8 + , -1 + ansats(11,8,1) = plusb8 + ansats(11,8,0) = anb8 - plusb8 ! 11m call slug (11, 9, varmax, varupp, varned, & ansats, org, lock(11,9), dubbel, low, & - start(11,9), stopp(11,9)) + start(11,9), stopp(11,9)) do anb9 = start(11,9), stopp(11,9), steg(11& - ,9) - antel(11,9) = anb9 + antel(11,8) + ,9) + antel(11,9) = anb9 + antel(11,8) if (.not.(antel(11,9)<=antal .and. ansats(& 11,8,1)<=2 .and. ansats(11,8,0)<=2)) & - cycle + cycle do plusb9 = min(anb9,20), max(anb9 - 18,0)& - , -1 - ansats(11,9,1) = plusb9 - ansats(11,9,0) = anb9 - plusb9 + , -1 + ansats(11,9,1) = plusb9 + ansats(11,9,0) = anb9 - plusb9 ! 11n call slug (11, 10, varmax, varupp, varned, & ansats, org, lock(11,10), dubbel, low, & - start(11,10), stopp(11,10)) + start(11,10), stopp(11,10)) do anba = start(11,10), stopp(11,10), steg(& - 11,10) - antel(11,10) = anba + antel(11,9) + 11,10) + antel(11,10) = anba + antel(11,9) if (.not.(antel(11,10)<=antal .and. ansats(& 11,9,1)<=2 .and. ansats(11,9,0)<=2& - .and. antel(11,10)>=lim(11))) cycle + .and. antel(11,10)>=lim(11))) cycle do plusba = min(anba,22), max(anba - 20,0)& - , -1 - ansats(11,10,1) = plusba - ansats(11,10,0) = anba - plusba + , -1 + ansats(11,10,1) = plusba + ansats(11,10,0) = anba - plusba ! 12s call slug (12, 0, varmax, varupp, varned, & ansats, org, lock(12,0), dubbel, low, & - start(12,0), stopp(12,0)) + start(12,0), stopp(12,0)) do anc0 = start(12,0), stopp(12,0), steg(12& - ,0) - antel(12,0) = anc0 + antel(11,10) + ,0) + antel(12,0) = anc0 + antel(11,10) if (.not.(antel(12,0)<=antal .and. ansats(& 11,10,1)<=2 .and. ansats(11,10,0)<=2)) & - cycle - ansats(12,0,0) = anc0 + cycle + ansats(12,0,0) = anc0 ! 12p call slug (12, 1, varmax, varupp, varned, & ansats, org, lock(12,1), dubbel, low, & - start(12,1), stopp(12,1)) + start(12,1), stopp(12,1)) do anc1 = start(12,1), stopp(12,1), steg(12& - ,1) - antel(12,1) = anc1 + antel(12,0) - if (antel(12,1) > antal) cycle + ,1) + antel(12,1) = anc1 + antel(12,0) + if (antel(12,1) > antal) cycle do plusc1 = min(anc1,4), max(anc1 - 2,0), & - -1 - ansats(12,1,1) = plusc1 - ansats(12,1,0) = anc1 - plusc1 + -1 + ansats(12,1,1) = plusc1 + ansats(12,1,0) = anc1 - plusc1 ! 12d call slug (12, 2, varmax, varupp, varned, & ansats, org, lock(12,2), dubbel, low, & - start(12,2), stopp(12,2)) + start(12,2), stopp(12,2)) do anc2 = start(12,2), stopp(12,2), steg(12& - ,2) - antel(12,2) = anc2 + antel(12,1) - if (antel(12,2) > antal) cycle + ,2) + antel(12,2) = anc2 + antel(12,1) + if (antel(12,2) > antal) cycle do plusc2 = min(anc2,6), max(anc2 - 4,0), & - -1 - ansats(12,2,1) = plusc2 - ansats(12,2,0) = anc2 - plusc2 + -1 + ansats(12,2,1) = plusc2 + ansats(12,2,0) = anc2 - plusc2 ! 12f call slug (12, 3, varmax, varupp, varned, & ansats, org, lock(12,3), dubbel, low, & - start(12,3), stopp(12,3)) + start(12,3), stopp(12,3)) do anc3 = start(12,3), stopp(12,3), steg(12& - ,3) - antel(12,3) = anc3 + antel(12,2) - if (antel(12,3) > antal) cycle + ,3) + antel(12,3) = anc3 + antel(12,2) + if (antel(12,3) > antal) cycle do plusc3 = min(anc3,8), max(anc3 - 6,0), & - -1 - ansats(12,3,1) = plusc3 - ansats(12,3,0) = anc3 - plusc3 + -1 + ansats(12,3,1) = plusc3 + ansats(12,3,0) = anc3 - plusc3 ! 12g call slug (12, 4, varmax, varupp, varned, & ansats, org, lock(12,4), dubbel, low, & - start(12,4), stopp(12,4)) + start(12,4), stopp(12,4)) do anc4 = start(12,4), stopp(12,4), steg(12& - ,4) - antel(12,4) = anc4 + antel(12,3) - if (antel(12,4) > antal) cycle + ,4) + antel(12,4) = anc4 + antel(12,3) + if (antel(12,4) > antal) cycle do plusc4 = min(anc4,10), max(anc4 - 8,0), & - -1 - ansats(12,4,1) = plusc4 - ansats(12,4,0) = anc4 - plusc4 + -1 + ansats(12,4,1) = plusc4 + ansats(12,4,0) = anc4 - plusc4 ! 12h call slug (12, 5, varmax, varupp, varned, & ansats, org, lock(12,5), dubbel, low, & - start(12,5), stopp(12,5)) + start(12,5), stopp(12,5)) do anc5 = start(12,5), stopp(12,5), steg(12& - ,5) - antel(12,5) = anc5 + antel(12,4) + ,5) + antel(12,5) = anc5 + antel(12,4) if (antel(12,5)>antal .or. ansats(12,4,1)>2& - ) cycle + ) cycle do plusc5 = min(anc5,12), max(anc5 - 10,0)& - , -1 - ansats(12,5,1) = plusc5 - ansats(12,5,0) = anc5 - plusc5 + , -1 + ansats(12,5,1) = plusc5 + ansats(12,5,0) = anc5 - plusc5 ! 12i call slug (12, 6, varmax, varupp, varned, & ansats, org, lock(12,6), dubbel, low, & - start(12,6), stopp(12,6)) + start(12,6), stopp(12,6)) do anc6 = start(12,6), stopp(12,6), steg(12& - ,6) - antel(12,6) = anc6 + antel(12,5) + ,6) + antel(12,6) = anc6 + antel(12,5) if (.not.(antel(12,6)<=antal .and. ansats(& 12,5,1)<=2 .and. ansats(12,5,0)<=2)) & - cycle + cycle do plusc6 = min(anc6,14), max(anc6 - 12,0)& - , -1 - ansats(12,6,1) = plusc6 - ansats(12,6,0) = anc6 - plusc6 + , -1 + ansats(12,6,1) = plusc6 + ansats(12,6,0) = anc6 - plusc6 ! 12k call slug (12, 7, varmax, varupp, varned, & ansats, org, lock(12,7), dubbel, low, & - start(12,7), stopp(12,7)) + start(12,7), stopp(12,7)) do anc7 = start(12,7), stopp(12,7), steg(12& - ,7) - antel(12,7) = anc7 + antel(12,6) + ,7) + antel(12,7) = anc7 + antel(12,6) if (.not.(antel(12,7)<=antal .and. ansats(& 12,6,1)<=2 .and. ansats(12,6,0)<=2)) & - cycle + cycle do plusc7 = min(anc7,16), max(anc7 - 14,0)& - , -1 - ansats(12,7,1) = plusc7 - ansats(12,7,0) = anc7 - plusc7 + , -1 + ansats(12,7,1) = plusc7 + ansats(12,7,0) = anc7 - plusc7 ! 12l call slug (12, 8, varmax, varupp, varned, & ansats, org, lock(12,8), dubbel, low, & - start(12,8), stopp(12,8)) + start(12,8), stopp(12,8)) do anc8 = start(12,8), stopp(12,8), steg(12& - ,8) - antel(12,8) = anc8 + antel(12,7) + ,8) + antel(12,8) = anc8 + antel(12,7) if (.not.(antel(12,8)<=antal .and. ansats(& 12,7,1)<=2 .and. ansats(12,7,0)<=2)) & - cycle + cycle do plusc8 = min(anc8,18), max(anc8 - 16,0)& - , -1 - ansats(12,8,1) = plusc8 - ansats(12,8,0) = anc8 - plusc8 + , -1 + ansats(12,8,1) = plusc8 + ansats(12,8,0) = anc8 - plusc8 ! 12m call slug (12, 9, varmax, varupp, varned, & ansats, org, lock(12,9), dubbel, low, & - start(12,9), stopp(12,9)) + start(12,9), stopp(12,9)) do anc9 = start(12,9), stopp(12,9), steg(12& - ,9) - antel(12,9) = anc9 + antel(12,8) + ,9) + antel(12,9) = anc9 + antel(12,8) if (.not.(antel(12,9)<=antal .and. ansats(& 12,8,1)<=2 .and. ansats(12,8,0)<=2)) & - cycle + cycle do plusc9 = min(anc9,20), max(anc9 - 18,0)& - , -1 - ansats(12,9,1) = plusc9 - ansats(12,9,0) = anc9 - plusc9 + , -1 + ansats(12,9,1) = plusc9 + ansats(12,9,0) = anc9 - plusc9 ! 12n call slug (12, 10, varmax, varupp, varned, & ansats, org, lock(12,10), dubbel, low, & - start(12,10), stopp(12,10)) + start(12,10), stopp(12,10)) do anca = start(12,10), stopp(12,10), steg(& - 12,10) - antel(12,10) = anca + antel(12,9) + 12,10) + antel(12,10) = anca + antel(12,9) if (.not.(antel(12,10)<=antal .and. ansats(& 12,9,1)<=2 .and. ansats(12,9,0)<=2& - .and. antel(12,10)>=lim(12))) cycle + .and. antel(12,10)>=lim(12))) cycle do plusca = min(anca,22), max(anca - 20,0)& - , -1 - ansats(12,10,1) = plusca - ansats(12,10,0) = anca - plusca + , -1 + ansats(12,10,1) = plusca + ansats(12,10,0) = anca - plusca ! 13s call slug (13, 0, varmax, varupp, varned, & ansats, org, lock(13,0), dubbel, low, & - start(13,0), stopp(13,0)) + start(13,0), stopp(13,0)) do and0 = start(13,0), stopp(13,0), steg(13& - ,0) - antel(13,0) = and0 + antel(12,10) + ,0) + antel(13,0) = and0 + antel(12,10) if (.not.(antel(13,0)<=antal .and. ansats(& 12,10,1)<=2 .and. ansats(12,10,0)<=2)) & - cycle - ansats(13,0,0) = and0 + cycle + ansats(13,0,0) = and0 ! 13p call slug (13, 1, varmax, varupp, varned, & ansats, org, lock(13,1), dubbel, low, & - start(13,1), stopp(13,1)) + start(13,1), stopp(13,1)) do and1 = start(13,1), stopp(13,1), steg(13& - ,1) - antel(13,1) = and1 + antel(13,0) - if (antel(13,1) > antal) cycle + ,1) + antel(13,1) = and1 + antel(13,0) + if (antel(13,1) > antal) cycle do plusd1 = min(and1,4), max(and1 - 2,0), & - -1 - ansats(13,1,1) = plusd1 - ansats(13,1,0) = and1 - plusd1 + -1 + ansats(13,1,1) = plusd1 + ansats(13,1,0) = and1 - plusd1 ! 13d call slug (13, 2, varmax, varupp, varned, & ansats, org, lock(13,2), dubbel, low, & - start(13,2), stopp(13,2)) + start(13,2), stopp(13,2)) do and2 = start(13,2), stopp(13,2), steg(13& - ,2) - antel(13,2) = and2 + antel(13,1) - if (antel(13,2) > antal) cycle + ,2) + antel(13,2) = and2 + antel(13,1) + if (antel(13,2) > antal) cycle do plusd2 = min(and2,6), max(and2 - 4,0), & - -1 - ansats(13,2,1) = plusd2 - ansats(13,2,0) = and2 - plusd2 + -1 + ansats(13,2,1) = plusd2 + ansats(13,2,0) = and2 - plusd2 ! 13f call slug (13, 3, varmax, varupp, varned, & ansats, org, lock(13,3), dubbel, low, & - start(13,3), stopp(13,3)) + start(13,3), stopp(13,3)) do and3 = start(13,3), stopp(13,3), steg(13& - ,3) - antel(13,3) = and3 + antel(13,2) - if (antel(13,3) > antal) cycle + ,3) + antel(13,3) = and3 + antel(13,2) + if (antel(13,3) > antal) cycle do plusd3 = min(and3,8), max(and3 - 6,0), & - -1 - ansats(13,3,1) = plusd3 - ansats(13,3,0) = and3 - plusd3 + -1 + ansats(13,3,1) = plusd3 + ansats(13,3,0) = and3 - plusd3 ! 13g call slug (13, 4, varmax, varupp, varned, & ansats, org, lock(13,4), dubbel, low, & - start(13,4), stopp(13,4)) + start(13,4), stopp(13,4)) do and4 = start(13,4), stopp(13,4), steg(13& - ,4) - antel(13,4) = and4 + antel(13,3) - if (antel(13,4) > antal) cycle + ,4) + antel(13,4) = and4 + antel(13,3) + if (antel(13,4) > antal) cycle do plusd4 = min(and4,10), max(and4 - 8,0), & - -1 - ansats(13,4,1) = plusd4 - ansats(13,4,0) = and4 - plusd4 + -1 + ansats(13,4,1) = plusd4 + ansats(13,4,0) = and4 - plusd4 ! 13h call slug (13, 5, varmax, varupp, varned, & ansats, org, lock(13,5), dubbel, low, & - start(13,5), stopp(13,5)) + start(13,5), stopp(13,5)) do and5 = start(13,5), stopp(13,5), steg(13& - ,5) - antel(13,5) = and5 + antel(13,4) + ,5) + antel(13,5) = and5 + antel(13,4) if (antel(13,5)>antal .or. ansats(13,4,1)>2& - ) cycle + ) cycle do plusd5 = min(and5,12), max(and5 - 10,0)& - , -1 - ansats(13,5,1) = plusd5 - ansats(13,5,0) = and5 - plusd5 + , -1 + ansats(13,5,1) = plusd5 + ansats(13,5,0) = and5 - plusd5 ! 13i call slug (13, 6, varmax, varupp, varned, & ansats, org, lock(13,6), dubbel, low, & - start(13,6), stopp(13,6)) + start(13,6), stopp(13,6)) do and6 = start(13,6), stopp(13,6), steg(13& - ,6) - antel(13,6) = and6 + antel(13,5) + ,6) + antel(13,6) = and6 + antel(13,5) if (.not.(antel(13,6)<=antal .and. ansats(& 13,5,1)<=2 .and. ansats(13,5,0)<=2)) & - cycle + cycle do plusd6 = min(and6,14), max(and6 - 12,0)& - , -1 - ansats(13,6,1) = plusd6 - ansats(13,6,0) = and6 - plusd6 + , -1 + ansats(13,6,1) = plusd6 + ansats(13,6,0) = and6 - plusd6 ! 13k call slug (13, 7, varmax, varupp, varned, & ansats, org, lock(13,7), dubbel, low, & - start(13,7), stopp(13,7)) + start(13,7), stopp(13,7)) do and7 = start(13,7), stopp(13,7), steg(13& - ,7) - antel(13,7) = and7 + antel(13,6) + ,7) + antel(13,7) = and7 + antel(13,6) if (.not.(antel(13,7)<=antal .and. ansats(& 13,6,1)<=2 .and. ansats(13,6,0)<=2)) & - cycle + cycle do plusd7 = min(and7,16), max(and7 - 14,0)& - , -1 - ansats(13,7,1) = plusd7 - ansats(13,7,0) = and7 - plusd7 + , -1 + ansats(13,7,1) = plusd7 + ansats(13,7,0) = and7 - plusd7 ! 13l call slug (13, 8, varmax, varupp, varned, & ansats, org, lock(13,8), dubbel, low, & - start(13,8), stopp(13,8)) + start(13,8), stopp(13,8)) do and8 = start(13,8), stopp(13,8), steg(13& - ,8) - antel(13,8) = and8 + antel(13,7) + ,8) + antel(13,8) = and8 + antel(13,7) if (.not.(antel(13,8)<=antal .and. ansats(& 13,7,1)<=2 .and. ansats(13,7,0)<=2)) & - cycle + cycle do plusd8 = min(and8,18), max(and8 - 16,0)& - , -1 - ansats(13,8,1) = plusd8 - ansats(13,8,0) = and8 - plusd8 + , -1 + ansats(13,8,1) = plusd8 + ansats(13,8,0) = and8 - plusd8 ! 13m call slug (13, 9, varmax, varupp, varned, & ansats, org, lock(13,9), dubbel, low, & - start(13,9), stopp(13,9)) + start(13,9), stopp(13,9)) do and9 = start(13,9), stopp(13,9), steg(13& - ,9) - antel(13,9) = and9 + antel(13,8) + ,9) + antel(13,9) = and9 + antel(13,8) if (.not.(antel(13,9)<=antal .and. ansats(& 13,8,1)<=2 .and. ansats(13,8,0)<=2)) & - cycle + cycle do plusd9 = min(and9,20), max(and9 - 18,0)& - , -1 - ansats(13,9,1) = plusd9 - ansats(13,9,0) = and9 - plusd9 + , -1 + ansats(13,9,1) = plusd9 + ansats(13,9,0) = and9 - plusd9 ! 13n call slug (13, 10, varmax, varupp, varned, & ansats, org, lock(13,10), dubbel, low, & - start(13,10), stopp(13,10)) + start(13,10), stopp(13,10)) do anda = start(13,10), stopp(13,10), steg(& - 13,10) - antel(13,10) = anda + antel(13,9) + 13,10) + antel(13,10) = anda + antel(13,9) if (.not.(antel(13,10)<=antal .and. ansats(& 13,9,1)<=2 .and. ansats(13,9,0)<=2& - .and. antel(13,10)>=lim(13))) cycle + .and. antel(13,10)>=lim(13))) cycle do plusda = min(anda,22), max(anda - 20,0)& - , -1 - ansats(13,10,1) = plusda - ansats(13,10,0) = anda - plusda + , -1 + ansats(13,10,1) = plusda + ansats(13,10,0) = anda - plusda ! 14s call slug (14, 0, varmax, varupp, varned, & ansats, org, lock(14,0), dubbel, low, & - start(14,0), stopp(14,0)) + start(14,0), stopp(14,0)) do ane0 = start(14,0), stopp(14,0), steg(14& - ,0) - antel(14,0) = ane0 + antel(13,10) + ,0) + antel(14,0) = ane0 + antel(13,10) if (.not.(antel(14,0)<=antal .and. ansats(& 13,10,1)<=2 .and. ansats(13,10,0)<=2)) & - cycle - ansats(14,0,0) = ane0 + cycle + ansats(14,0,0) = ane0 ! 14p call slug (14, 1, varmax, varupp, varned, & ansats, org, lock(14,1), dubbel, low, & - start(14,1), stopp(14,1)) + start(14,1), stopp(14,1)) do ane1 = start(14,1), stopp(14,1), steg(14& - ,1) - antel(14,1) = ane1 + antel(14,0) - if (antel(14,1) > antal) cycle + ,1) + antel(14,1) = ane1 + antel(14,0) + if (antel(14,1) > antal) cycle do pluse1 = min(ane1,4), max(ane1 - 2,0), & - -1 - ansats(14,1,1) = pluse1 - ansats(14,1,0) = ane1 - pluse1 + -1 + ansats(14,1,1) = pluse1 + ansats(14,1,0) = ane1 - pluse1 ! 14d call slug (14, 2, varmax, varupp, varned, & ansats, org, lock(14,2), dubbel, low, & - start(14,2), stopp(14,2)) + start(14,2), stopp(14,2)) do ane2 = start(14,2), stopp(14,2), steg(14& - ,2) - antel(14,2) = ane2 + antel(14,1) - if (antel(14,2) > antal) cycle + ,2) + antel(14,2) = ane2 + antel(14,1) + if (antel(14,2) > antal) cycle do pluse2 = min(ane2,6), max(ane2 - 4,0), & - -1 - ansats(14,2,1) = pluse2 - ansats(14,2,0) = ane2 - pluse2 + -1 + ansats(14,2,1) = pluse2 + ansats(14,2,0) = ane2 - pluse2 ! 14f call slug (14, 3, varmax, varupp, varned, & ansats, org, lock(14,3), dubbel, low, & - start(14,3), stopp(14,3)) + start(14,3), stopp(14,3)) do ane3 = start(14,3), stopp(14,3), steg(14& - ,3) - antel(14,3) = ane3 + antel(14,2) - if (antel(14,3) > antal) cycle + ,3) + antel(14,3) = ane3 + antel(14,2) + if (antel(14,3) > antal) cycle do pluse3 = min(ane3,8), max(ane3 - 6,0), & - -1 - ansats(14,3,1) = pluse3 - ansats(14,3,0) = ane3 - pluse3 + -1 + ansats(14,3,1) = pluse3 + ansats(14,3,0) = ane3 - pluse3 ! 14g call slug (14, 4, varmax, varupp, varned, & ansats, org, lock(14,4), dubbel, low, & - start(14,4), stopp(14,4)) + start(14,4), stopp(14,4)) do ane4 = start(14,4), stopp(14,4), steg(14& - ,4) - antel(14,4) = ane4 + antel(14,3) - if (antel(14,4) > antal) cycle + ,4) + antel(14,4) = ane4 + antel(14,3) + if (antel(14,4) > antal) cycle do pluse4 = min(ane4,10), max(ane4 - 8,0), & - -1 - ansats(14,4,1) = pluse4 - ansats(14,4,0) = ane4 - pluse4 + -1 + ansats(14,4,1) = pluse4 + ansats(14,4,0) = ane4 - pluse4 ! 14h call slug (14, 5, varmax, varupp, varned, & ansats, org, lock(14,5), dubbel, low, & - start(14,5), stopp(14,5)) + start(14,5), stopp(14,5)) do ane5 = start(14,5), stopp(14,5), steg(14& - ,5) - antel(14,5) = ane5 + antel(14,4) + ,5) + antel(14,5) = ane5 + antel(14,4) if (antel(14,5)>antal .or. ansats(14,4,1)>2& - ) cycle + ) cycle do pluse5 = min(ane5,12), max(ane5 - 10,0)& - , -1 - ansats(14,5,1) = pluse5 - ansats(14,5,0) = ane5 - pluse5 + , -1 + ansats(14,5,1) = pluse5 + ansats(14,5,0) = ane5 - pluse5 ! 14i call slug (14, 6, varmax, varupp, varned, & ansats, org, lock(14,6), dubbel, low, & - start(14,6), stopp(14,6)) + start(14,6), stopp(14,6)) do ane6 = start(14,6), stopp(14,6), steg(14& - ,6) - antel(14,6) = ane6 + antel(14,5) + ,6) + antel(14,6) = ane6 + antel(14,5) if (.not.(antel(14,6)<=antal .and. ansats(& 14,5,1)<=2 .and. ansats(14,5,0)<=2)) & - cycle + cycle do pluse6 = min(ane6,14), max(ane6 - 12,0)& - , -1 - ansats(14,6,1) = pluse6 - ansats(14,6,0) = ane6 - pluse6 + , -1 + ansats(14,6,1) = pluse6 + ansats(14,6,0) = ane6 - pluse6 ! 14k call slug (14, 7, varmax, varupp, varned, & ansats, org, lock(14,7), dubbel, low, & - start(14,7), stopp(14,7)) + start(14,7), stopp(14,7)) do ane7 = start(14,7), stopp(14,7), steg(14& - ,7) - antel(14,7) = ane7 + antel(14,6) + ,7) + antel(14,7) = ane7 + antel(14,6) if (.not.(antel(14,7)<=antal .and. ansats(& 14,6,1)<=2 .and. ansats(14,6,0)<=2)) & - cycle + cycle do pluse7 = min(ane7,16), max(ane7 - 14,0)& - , -1 - ansats(14,7,1) = pluse7 - ansats(14,7,0) = ane7 - pluse7 + , -1 + ansats(14,7,1) = pluse7 + ansats(14,7,0) = ane7 - pluse7 ! 14l call slug (14, 8, varmax, varupp, varned, & ansats, org, lock(14,8), dubbel, low, & - start(14,8), stopp(14,8)) + start(14,8), stopp(14,8)) do ane8 = start(14,8), stopp(14,8), steg(14& - ,8) - antel(14,8) = ane8 + antel(14,7) + ,8) + antel(14,8) = ane8 + antel(14,7) if (.not.(antel(14,8)<=antal .and. ansats(& 14,7,1)<=2 .and. ansats(14,7,0)<=2)) & - cycle + cycle do pluse8 = min(ane8,18), max(ane8 - 16,0)& - , -1 - ansats(14,8,1) = pluse8 - ansats(14,8,0) = ane8 - pluse8 + , -1 + ansats(14,8,1) = pluse8 + ansats(14,8,0) = ane8 - pluse8 ! 14m call slug (14, 9, varmax, varupp, varned, & ansats, org, lock(14,9), dubbel, low, & - start(14,9), stopp(14,9)) + start(14,9), stopp(14,9)) do ane9 = start(14,9), stopp(14,9), steg(14& - ,9) - antel(14,9) = ane9 + antel(14,8) + ,9) + antel(14,9) = ane9 + antel(14,8) if (.not.(antel(14,9)<=antal .and. ansats(& 14,8,1)<=2 .and. ansats(14,8,0)<=2)) & - cycle + cycle do pluse9 = min(ane9,20), max(ane9 - 18,0)& - , -1 - ansats(14,9,1) = pluse9 - ansats(14,9,0) = ane9 - pluse9 + , -1 + ansats(14,9,1) = pluse9 + ansats(14,9,0) = ane9 - pluse9 ! 14n call slug (14, 10, varmax, varupp, varned, & ansats, org, lock(14,10), dubbel, low, & - start(14,10), stopp(14,10)) + start(14,10), stopp(14,10)) do anea = start(14,10), stopp(14,10), steg(& - 14,10) - antel(14,10) = anea + antel(14,9) + 14,10) + antel(14,10) = anea + antel(14,9) if (.not.(antel(14,10)<=antal .and. ansats(& 14,9,1)<=2 .and. ansats(14,9,0)<=2& - .and. antel(14,10)>=lim(14))) cycle + .and. antel(14,10)>=lim(14))) cycle do plusea = min(anea,22), max(anea - 20,0)& - , -1 - ansats(14,10,1) = plusea - ansats(14,10,0) = anea - plusea + , -1 + ansats(14,10,1) = plusea + ansats(14,10,0) = anea - plusea ! 15s call slug (15, 0, varmax, varupp, varned, & ansats, org, lock(15,0), dubbel, low, & - start(15,0), stopp(15,0)) + start(15,0), stopp(15,0)) do anf0 = start(15,0), stopp(15,0), steg(15& - ,0) - antel(15,0) = anf0 + antel(14,10) + ,0) + antel(15,0) = anf0 + antel(14,10) if (.not.(antel(15,0)<=antal .and. ansats(& 14,10,1)<=2 .and. ansats(14,10,0)<=2)) & - cycle - ansats(15,0,0) = anf0 + cycle + ansats(15,0,0) = anf0 ! 15p call slug (15, 1, varmax, varupp, varned, & ansats, org, lock(15,1), dubbel, low, & - start(15,1), stopp(15,1)) + start(15,1), stopp(15,1)) do anf1 = start(15,1), stopp(15,1), steg(15& - ,1) - antel(15,1) = anf1 + antel(15,0) - if (antel(15,1) > antal) cycle + ,1) + antel(15,1) = anf1 + antel(15,0) + if (antel(15,1) > antal) cycle do plusf1 = min(anf1,4), max(anf1 - 2,0), & - -1 - ansats(15,1,1) = plusf1 - ansats(15,1,0) = anf1 - plusf1 + -1 + ansats(15,1,1) = plusf1 + ansats(15,1,0) = anf1 - plusf1 ! 15d call slug (15, 2, varmax, varupp, varned, & ansats, org, lock(15,2), dubbel, low, & - start(15,2), stopp(15,2)) + start(15,2), stopp(15,2)) do anf2 = start(15,2), stopp(15,2), steg(15& - ,2) - antel(15,2) = anf2 + antel(15,1) - if (antel(15,2) > antal) cycle + ,2) + antel(15,2) = anf2 + antel(15,1) + if (antel(15,2) > antal) cycle do plusf2 = min(anf2,6), max(anf2 - 4,0), & - -1 - ansats(15,2,1) = plusf2 - ansats(15,2,0) = anf2 - plusf2 + -1 + ansats(15,2,1) = plusf2 + ansats(15,2,0) = anf2 - plusf2 ! 15f call slug (15, 3, varmax, varupp, varned, & ansats, org, lock(15,3), dubbel, low, & - start(15,3), stopp(15,3)) + start(15,3), stopp(15,3)) do anf3 = start(15,3), stopp(15,3), steg(15& - ,3) - antel(15,3) = anf3 + antel(15,2) - if (antel(15,3) > antal) cycle + ,3) + antel(15,3) = anf3 + antel(15,2) + if (antel(15,3) > antal) cycle do plusf3 = min(anf3,8), max(anf3 - 6,0), & - -1 - ansats(15,3,1) = plusf3 - ansats(15,3,0) = anf3 - plusf3 + -1 + ansats(15,3,1) = plusf3 + ansats(15,3,0) = anf3 - plusf3 ! 15g call slug (15, 4, varmax, varupp, varned, & ansats, org, lock(15,4), dubbel, low, & - start(15,4), stopp(15,4)) + start(15,4), stopp(15,4)) do anf4 = start(15,4), stopp(15,4), steg(15& - ,4) - antel(15,4) = anf4 + antel(15,3) - if (antel(15,4) > antal) cycle + ,4) + antel(15,4) = anf4 + antel(15,3) + if (antel(15,4) > antal) cycle do plusf4 = min(anf4,10), max(anf4 - 8,0), & - -1 - ansats(15,4,1) = plusf4 - ansats(15,4,0) = anf4 - plusf4 + -1 + ansats(15,4,1) = plusf4 + ansats(15,4,0) = anf4 - plusf4 ! 15h call slug (15, 5, varmax, varupp, varned, & ansats, org, lock(15,5), dubbel, low, & - start(15,5), stopp(15,5)) + start(15,5), stopp(15,5)) do anf5 = start(15,5), stopp(15,5), steg(15& - ,5) - antel(15,5) = anf5 + antel(15,4) + ,5) + antel(15,5) = anf5 + antel(15,4) if (antel(15,5)>antal .or. ansats(15,4,1)>2& - ) cycle + ) cycle do plusf5 = min(anf5,12), max(anf5 - 10,0)& - , -1 - ansats(15,5,1) = plusf5 - ansats(15,5,0) = anf5 - plusf5 + , -1 + ansats(15,5,1) = plusf5 + ansats(15,5,0) = anf5 - plusf5 ! 15i call slug (15, 6, varmax, varupp, varned, & ansats, org, lock(15,6), dubbel, low, & - start(15,6), stopp(15,6)) + start(15,6), stopp(15,6)) do anf6 = start(15,6), stopp(15,6), steg(15& - ,6) - antel(15,6) = anf6 + antel(15,5) + ,6) + antel(15,6) = anf6 + antel(15,5) if (.not.(antel(15,6)<=antal .and. ansats(& 15,5,1)<=2 .and. ansats(15,5,0)<=2)) & - cycle + cycle do plusf6 = min(anf6,14), max(anf6 - 12,0)& - , -1 - ansats(15,6,1) = plusf6 - ansats(15,6,0) = anf6 - plusf6 + , -1 + ansats(15,6,1) = plusf6 + ansats(15,6,0) = anf6 - plusf6 ! 15k call slug (15, 7, varmax, varupp, varned, & ansats, org, lock(15,7), dubbel, low, & - start(15,7), stopp(15,7)) + start(15,7), stopp(15,7)) do anf7 = start(15,7), stopp(15,7), steg(15& - ,7) - antel(15,7) = anf7 + antel(15,6) + ,7) + antel(15,7) = anf7 + antel(15,6) if (.not.(antel(15,7)<=antal .and. ansats(& 15,6,1)<=2 .and. ansats(15,6,0)<=2)) & - cycle + cycle do plusf7 = min(anf7,16), max(anf7 - 14,0)& - , -1 - ansats(15,7,1) = plusf7 - ansats(15,7,0) = anf7 - plusf7 + , -1 + ansats(15,7,1) = plusf7 + ansats(15,7,0) = anf7 - plusf7 ! 15l call slug (15, 8, varmax, varupp, varned, & ansats, org, lock(15,8), dubbel, low, & - start(15,8), stopp(15,8)) + start(15,8), stopp(15,8)) do anf8 = start(15,8), stopp(15,8), steg(15& - ,8) - antel(15,8) = anf8 + antel(15,7) + ,8) + antel(15,8) = anf8 + antel(15,7) if (.not.(antel(15,8)<=antal .and. ansats(& 15,7,1)<=2 .and. ansats(15,7,0)<=2)) & - cycle + cycle do plusf8 = min(anf8,18), max(anf8 - 16,0)& - , -1 - ansats(15,8,1) = plusf8 - ansats(15,8,0) = anf8 - plusf8 + , -1 + ansats(15,8,1) = plusf8 + ansats(15,8,0) = anf8 - plusf8 ! 15m call slug (15, 9, varmax, varupp, varned, & ansats, org, lock(15,9), dubbel, low, & - start(15,9), stopp(15,9)) + start(15,9), stopp(15,9)) do anf9 = start(15,9), stopp(15,9), steg(15& - ,9) - antel(15,9) = anf9 + antel(15,8) + ,9) + antel(15,9) = anf9 + antel(15,8) if (.not.(antel(15,9)<=antal .and. ansats(& 15,8,1)<=2 .and. ansats(15,8,0)<=2)) & - cycle + cycle do plusf9 = min(anf9,20), max(anf9 - 18,0)& - , -1 - ansats(15,9,1) = plusf9 - ansats(15,9,0) = anf9 - plusf9 + , -1 + ansats(15,9,1) = plusf9 + ansats(15,9,0) = anf9 - plusf9 ! 15n call slug (15, 10, varmax, varupp, varned, & ansats, org, lock(15,10), dubbel, low, & - start(15,10), stopp(15,10)) + start(15,10), stopp(15,10)) do anfa = start(15,10), stopp(15,10), steg(& - 15,10) - antel(15,10) = anfa + antel(15,9) + 15,10) + antel(15,10) = anfa + antel(15,9) if (.not.(antel(15,10)==antal .and. ansats(& 15,9,1)<=2 .and. ansats(15,9,0)<=2)) & - cycle + cycle do plusfa = min(anfa,22), max(anfa - 20,0)& - , -1 - ansats(15,10,1) = plusfa - ansats(15,10,0) = anfa - plusfa + , -1 + ansats(15,10,1) = plusfa + ansats(15,10,0) = anfa - plusfa if (ansats(15,10,1)>2 .or. ansats(15,10,0)>& - 2) cycle - par = 0 - elar = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, min(j,1) - elar = elar + ansats(i,j,k) - par = mod(par + j*ansats(i,j,k),2) - end do - end do - end do - if (par /= par0) cycle - if (elar == antal) then + 2) cycle + par = 0 + elar = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, min(j,1) + elar = elar + ansats(i,j,k) + par = mod(par + j*ansats(i,j,k),2) + end do + end do + end do + if (par /= par0) cycle + if (elar == antal) then call gen (ansats, posn, posl, skal, cf, & - first, minj, maxj, par0) - else - write (*, *) 'FEL' - endif - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - if (first) then - rewind (fil_1) - else - rewind (fil_2) - endif - if (cf == 0) then - write (*, 1005) 'No configuration state has been generated.' - else if (cf == 1) then - write (*, 1005) 'One configuration state has been generated.' - else if (cf < 10) then - write (*, 1001) cf, ' configuration states have been generated.' - else if (cf < 100) then - write (*, 1002) cf, ' configuration states have been generated.' - else if (cf < 1000) then - write (*, 1003) cf, ' configuration states have been generated.' - else if (cf < 10000) then - write (*, 1004) cf, ' configuration states have been generated.' - else if (cf < 100000) then - write (*, 1006) cf, ' configuration states have been generated.' - else - write (*, *) cf, ' configuration states have been generated.' - endif + first, minj, maxj, par0) + else + write (*, *) 'FEL' + endif + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + if (first) then + rewind (fil_1) + else + rewind (fil_2) + endif + if (cf == 0) then + write (*, 1005) 'No configuration state has been generated.' + else if (cf == 1) then + write (*, 1005) 'One configuration state has been generated.' + else if (cf < 10) then + write (*, 1001) cf, ' configuration states have been generated.' + else if (cf < 100) then + write (*, 1002) cf, ' configuration states have been generated.' + else if (cf < 1000) then + write (*, 1003) cf, ' configuration states have been generated.' + else if (cf < 10000) then + write (*, 1004) cf, ' configuration states have been generated.' + else if (cf < 100000) then + write (*, 1006) cf, ' configuration states have been generated.' + else + write (*, *) cf, ' configuration states have been generated.' + endif ! 1000 format(A) - 1001 format(' ',i1,a) - 1002 format(' ',i2,a) - 1003 format(' ',i3,a) - 1004 format(' ',i4,a) - 1005 format(' ',a) - 1006 format(' ',i5,a) - 5000 format(11i2) - return - end subroutine blanda + 1001 format(' ',i1,a) + 1002 format(' ',i2,a) + 1003 format(' ',i3,a) + 1004 format(' ',i4,a) + 1005 format(' ',a) + 1006 format(' ',i5,a) + 5000 format(11i2) + return + end subroutine blanda diff --git a/src/appl/jjgen90/blanda_I.f90 b/src/appl/jjgen90/blanda_I.f90 index 973d58ef4..40e25001a 100644 --- a/src/appl/jjgen90/blanda_I.f90 +++ b/src/appl/jjgen90/blanda_I.f90 @@ -1,21 +1,21 @@ - MODULE blanda_I + MODULE blanda_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blanda (ORG, VARMAX, LOCK, MINJ, MAXJ, SKAL, NMAX, LOW, POSN& - , POSL, LIM, DUBBEL, FIRST) - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - integer :: VARMAX - logical, DIMENSION(15,0:10) :: LOCK - integer :: MINJ - integer :: MAXJ - integer :: SKAL - integer, INTENT(IN) :: NMAX - integer, DIMENSION(15,0:10) :: LOW - integer, DIMENSION(110) :: POSN - integer, DIMENSION(110) :: POSL - integer, DIMENSION(15), INTENT(IN) :: LIM - logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL - logical, INTENT(IN) :: FIRST - END SUBROUTINE - END INTERFACE - END MODULE + , POSL, LIM, DUBBEL, FIRST) + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + integer :: VARMAX + logical, DIMENSION(15,0:10) :: LOCK + integer :: MINJ + integer :: MAXJ + integer :: SKAL + integer, INTENT(IN) :: NMAX + integer, DIMENSION(15,0:10) :: LOW + integer, DIMENSION(110) :: POSN + integer, DIMENSION(110) :: POSL + integer, DIMENSION(15), INTENT(IN) :: LIM + logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL + logical, INTENT(IN) :: FIRST + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/blandb.f90 b/src/appl/jjgen90/blandb.f90 index b5d4ff70a..745cff8ea 100644 --- a/src/appl/jjgen90/blandb.f90 +++ b/src/appl/jjgen90/blandb.f90 @@ -1,43 +1,43 @@ ! last edited Januar 2, 1997 subroutine blandb(org, nmax, varmax, lock, fil, low, lim, posn, posl, & - minj, maxj) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + minj, maxj) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use sluggo_I + use sluggo_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: nmax - integer :: varmax - integer , intent(in) :: fil - integer :: minj - integer :: maxj - integer :: org(15,0:10) - integer :: low(15,0:10) - integer , intent(in) :: lim(15) - integer :: posn(110) - integer :: posl(110) - logical :: lock(15,0:10) + integer , intent(in) :: nmax + integer :: varmax + integer , intent(in) :: fil + integer :: minj + integer :: maxj + integer :: org(15,0:10) + integer :: low(15,0:10) + integer , intent(in) :: lim(15) + integer :: posn(110) + integer :: posl(110) + logical :: lock(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: antel, start - integer :: skal, cf - integer , dimension(15,0:10,0:1) :: ansats - integer , dimension(15,0:10) :: varupp, varned + integer , dimension(15,0:10) :: antel, start + integer :: skal, cf + integer , dimension(15,0:10,0:1) :: ansats + integer , dimension(15,0:10) :: varupp, varned integer :: an10, an20, an21, an30, an31, an32, an40, an41, an42, an43, k& , an50, an51, an52, an53, an54, an60, an61, an62, an63, an64, an65, & - an70, an71, an72, an73, an74, an75, an76 - integer , dimension(15,0:10) :: stopp + an70, an71, an72, an73, an74, an75, an76 + integer , dimension(15,0:10) :: stopp integer :: an80, an81, an82, an83, an84, an85, an86, an87, an90, an91, & an92, an93, an94, an95, an96, an97, an98, ana0, ana1, ana2, ana3, ana4& , ana5, ana6, ana7, ana8, ana9, plus21, plus31, plus32, plus41, plus42& @@ -56,1505 +56,1505 @@ subroutine blandb(org, nmax, varmax, lock, fil, low, lim, posn, posl, & anb6, anb7, anb8, anb9, anc0, anc1, anc2, anc3, anc4, anc5, anc6, anc7& , anc8, anc9, and0, and1, and2, and3, and4, and5, and6, and7, and8, & and9, ane0, ane1, ane2, ane3, ane4, ane5, ane6, ane7, ane8, ane9, anf0& - , anf1, anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 - real :: elar - logical :: first, finns + , anf1, anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 + real :: elar + logical :: first, finns !----------------------------------------------- ! - cf = 0 - antal = 0 - par0 = 0 - finns = .FALSE. - do i = 1, 15 - do j = 0, min(10,i - 1) - antal = antal + org(i,j) - par0 = mod(par0 + j*org(i,j),2) - end do - end do - if (nmax < 15) then - do i = nmax + 1, 15 - org(i,:min(10,i-1)) = 0 - end do - endif + cf = 0 + antal = 0 + par0 = 0 + finns = .FALSE. + do i = 1, 15 + do j = 0, min(10,i - 1) + antal = antal + org(i,j) + par0 = mod(par0 + j*org(i,j),2) + end do + end do + if (nmax < 15) then + do i = nmax + 1, 15 + org(i,:min(10,i-1)) = 0 + end do + endif ! 1s call sluggo (1, 0, varmax, varupp, varned, ansats, org, lock(1,0), low, & - start(1,0), stopp(1,0)) - do an10 = start(1,0), stopp(1,0), -1 - antel(1,0) = an10 - if (antel(1,0)>antal .or. antel(1,0)antal .or. antel(1,0) antal) cycle - ansats(2,0,0) = an20 + , start(2,0), stopp(2,0)) + do an20 = start(2,0), stopp(2,0), -1 + antel(2,0) = an20 + antel(1,0) + if (antel(2,0) > antal) cycle + ansats(2,0,0) = an20 ! 2p call sluggo (2, 1, varmax, varupp, varned, ansats, org, lock(2,1), & - low, start(2,1), stopp(2,1)) - do an21 = start(2,1), stopp(2,1), -1 - antel(2,1) = an21 + antel(2,0) - if (antel(2,1)>antal .or. antel(2,1)antal .or. antel(2,1) antal) cycle - ansats(3,0,0) = an30 + 3,0), low, start(3,0), stopp(3,0)) + do an30 = start(3,0), stopp(3,0), -1 + antel(3,0) = an30 + antel(2,1) + if (antel(3,0) > antal) cycle + ansats(3,0,0) = an30 ! 3p call sluggo (3, 1, varmax, varupp, varned, ansats, org, & - lock(3,1), low, start(3,1), stopp(3,1)) - do an31 = start(3,1), stopp(3,1), -1 - antel(3,1) = an31 + antel(3,0) - if (antel(3,1) > antal) cycle - do plus31 = min(an31,4), max(an31 - 2,0), -1 - ansats(3,1,1) = plus31 - ansats(3,1,0) = an31 - plus31 + lock(3,1), low, start(3,1), stopp(3,1)) + do an31 = start(3,1), stopp(3,1), -1 + antel(3,1) = an31 + antel(3,0) + if (antel(3,1) > antal) cycle + do plus31 = min(an31,4), max(an31 - 2,0), -1 + ansats(3,1,1) = plus31 + ansats(3,1,0) = an31 - plus31 ! 3d call sluggo (3, 2, varmax, varupp, varned, ansats, & - org, lock(3,2), low, start(3,2), stopp(3,2)) - do an32 = start(3,2), stopp(3,2), -1 - antel(3,2) = an32 + antel(3,1) + org, lock(3,2), low, start(3,2), stopp(3,2)) + do an32 = start(3,2), stopp(3,2), -1 + antel(3,2) = an32 + antel(3,1) if (antel(3,2)>antal .or. antel(3,2) antal) cycle - ansats(4,0,0) = an40 + stopp(4,0)) + do an40 = start(4,0), stopp(4,0), -1 + antel(4,0) = an40 + antel(3,2) + if (antel(4,0) > antal) cycle + ansats(4,0,0) = an40 ! 4p call sluggo (4, 1, varmax, varupp, varned, & ansats, org, lock(4,1), low, start(4,1)& - , stopp(4,1)) - do an41 = start(4,1), stopp(4,1), -1 - antel(4,1) = an41 + antel(4,0) - if (antel(4,1) > antal) cycle + , stopp(4,1)) + do an41 = start(4,1), stopp(4,1), -1 + antel(4,1) = an41 + antel(4,0) + if (antel(4,1) > antal) cycle do plus41 = min(an41,4), max(an41 - 2,0), & - -1 - ansats(4,1,1) = plus41 - ansats(4,1,0) = an41 - plus41 + -1 + ansats(4,1,1) = plus41 + ansats(4,1,0) = an41 - plus41 ! 4d call sluggo (4, 2, varmax, varupp, varned, & ansats, org, lock(4,2), low, start(4,2)& - , stopp(4,2)) - do an42 = start(4,2), stopp(4,2), -1 - antel(4,2) = an42 + antel(4,1) - if (antel(4,2) > antal) cycle + , stopp(4,2)) + do an42 = start(4,2), stopp(4,2), -1 + antel(4,2) = an42 + antel(4,1) + if (antel(4,2) > antal) cycle do plus42 = min(an42,6), max(an42 - 4,0), & - -1 - ansats(4,2,1) = plus42 - ansats(4,2,0) = an42 - plus42 + -1 + ansats(4,2,1) = plus42 + ansats(4,2,0) = an42 - plus42 ! 4f call sluggo (4, 3, varmax, varupp, varned, & ansats, org, lock(4,3), low, start(4,3)& - , stopp(4,3)) - do an43 = start(4,3), stopp(4,3), -1 - antel(4,3) = an43 + antel(4,2) + , stopp(4,3)) + do an43 = start(4,3), stopp(4,3), -1 + antel(4,3) = an43 + antel(4,2) if (antel(4,3)>antal .or. antel(4,3) antal) cycle - ansats(5,0,0) = an50 + , stopp(5,0)) + do an50 = start(5,0), stopp(5,0), -1 + antel(5,0) = an50 + antel(4,3) + if (antel(5,0) > antal) cycle + ansats(5,0,0) = an50 ! 5p call sluggo (5, 1, varmax, varupp, varned, & ansats, org, lock(5,1), low, start(5,1)& - , stopp(5,1)) - do an51 = start(5,1), stopp(5,1), -1 - antel(5,1) = an51 + antel(5,0) - if (antel(5,1) > antal) cycle + , stopp(5,1)) + do an51 = start(5,1), stopp(5,1), -1 + antel(5,1) = an51 + antel(5,0) + if (antel(5,1) > antal) cycle do plus51 = min(an51,4), max(an51 - 2,0), & - -1 - ansats(5,1,1) = plus51 - ansats(5,1,0) = an51 - plus51 + -1 + ansats(5,1,1) = plus51 + ansats(5,1,0) = an51 - plus51 ! 5d call sluggo (5, 2, varmax, varupp, varned, & ansats, org, lock(5,2), low, start(5,2)& - , stopp(5,2)) - do an52 = start(5,2), stopp(5,2), -1 - antel(5,2) = an52 + antel(5,1) - if (antel(5,2) > antal) cycle + , stopp(5,2)) + do an52 = start(5,2), stopp(5,2), -1 + antel(5,2) = an52 + antel(5,1) + if (antel(5,2) > antal) cycle do plus52 = min(an52,6), max(an52 - 4,0), & - -1 - ansats(5,2,1) = plus52 - ansats(5,2,0) = an52 - plus52 - + -1 + ansats(5,2,1) = plus52 + ansats(5,2,0) = an52 - plus52 + ! 5f call sluggo (5, 3, varmax, varupp, varned, & ansats, org, lock(5,3), low, start(5,3)& - , stopp(5,3)) - do an53 = start(5,3), stopp(5,3), -1 - antel(5,3) = an53 + antel(5,2) - if (antel(5,3) > antal) cycle + , stopp(5,3)) + do an53 = start(5,3), stopp(5,3), -1 + antel(5,3) = an53 + antel(5,2) + if (antel(5,3) > antal) cycle do plus53 = min(an53,8), max(an53 - 6,0), & - -1 - ansats(5,3,1) = plus53 - ansats(5,3,0) = an53 - plus53 + -1 + ansats(5,3,1) = plus53 + ansats(5,3,0) = an53 - plus53 ! 5g call sluggo (5, 4, varmax, varupp, varned, & ansats, org, lock(5,4), low, start(5,4)& - , stopp(5,4)) - do an54 = start(5,4), stopp(5,4), -1 - antel(5,4) = an54 + antel(5,3) + , stopp(5,4)) + do an54 = start(5,4), stopp(5,4), -1 + antel(5,4) = an54 + antel(5,3) if (antel(5,4)>antal .or. antel(5,4)antal .or. ansats(5,4,1)>2) & - cycle - ansats(6,0,0) = an60 + cycle + ansats(6,0,0) = an60 ! 6p call sluggo (6, 1, varmax, varupp, varned, & ansats, org, lock(6,1), low, start(6,1)& - , stopp(6,1)) - do an61 = start(6,1), stopp(6,1), -1 - antel(6,1) = an61 + antel(6,0) - if (antel(6,1) > antal) cycle + , stopp(6,1)) + do an61 = start(6,1), stopp(6,1), -1 + antel(6,1) = an61 + antel(6,0) + if (antel(6,1) > antal) cycle do plus61 = min(an61,4), max(an61 - 2,0), & - -1 - ansats(6,1,1) = plus61 - ansats(6,1,0) = an61 - plus61 + -1 + ansats(6,1,1) = plus61 + ansats(6,1,0) = an61 - plus61 ! 6d call sluggo (6, 2, varmax, varupp, varned, & ansats, org, lock(6,2), low, start(6,2)& - , stopp(6,2)) - do an62 = start(6,2), stopp(6,2), -1 - antel(6,2) = an62 + antel(6,1) - if (antel(6,2) > antal) cycle + , stopp(6,2)) + do an62 = start(6,2), stopp(6,2), -1 + antel(6,2) = an62 + antel(6,1) + if (antel(6,2) > antal) cycle do plus62 = min(an62,6), max(an62 - 4,0), & - -1 - ansats(6,2,1) = plus62 - ansats(6,2,0) = an62 - plus62 + -1 + ansats(6,2,1) = plus62 + ansats(6,2,0) = an62 - plus62 ! 6f call sluggo (6, 3, varmax, varupp, varned, & ansats, org, lock(6,3), low, start(6,3)& - , stopp(6,3)) - do an63 = start(6,3), stopp(6,3), -1 - antel(6,3) = an63 + antel(6,2) - if (antel(6,3) > antal) cycle + , stopp(6,3)) + do an63 = start(6,3), stopp(6,3), -1 + antel(6,3) = an63 + antel(6,2) + if (antel(6,3) > antal) cycle do plus63 = min(an63,8), max(an63 - 6,0), & - -1 - ansats(6,3,1) = plus63 - ansats(6,3,0) = an63 - plus63 + -1 + ansats(6,3,1) = plus63 + ansats(6,3,0) = an63 - plus63 ! 6g call sluggo (6, 4, varmax, varupp, varned, & ansats, org, lock(6,4), low, start(6,4)& - , stopp(6,4)) - do an64 = start(6,4), stopp(6,4), -1 - antel(6,4) = an64 + antel(6,3) - if (antel(6,4) > antal) cycle + , stopp(6,4)) + do an64 = start(6,4), stopp(6,4), -1 + antel(6,4) = an64 + antel(6,3) + if (antel(6,4) > antal) cycle do plus64 = min(an64,10), max(an64 - 8,0), & - -1 - ansats(6,4,1) = plus64 - ansats(6,4,0) = an64 - plus64 + -1 + ansats(6,4,1) = plus64 + ansats(6,4,0) = an64 - plus64 ! 6h call sluggo (6, 5, varmax, varupp, varned, & ansats, org, lock(6,5), low, start(6,5)& - , stopp(6,5)) - do an65 = start(6,5), stopp(6,5), -1 - antel(6,5) = an65 + antel(6,4) + , stopp(6,5)) + do an65 = start(6,5), stopp(6,5), -1 + antel(6,5) = an65 + antel(6,4) if (.not.(antel(6,5)<=antal .and. ansats(6,& 4,1)<=2 .and. antel(6,5)>=lim(6))) & - cycle + cycle do plus65 = min(an65,12), max(an65 - 10,0)& - , -1 - ansats(6,5,1) = plus65 - ansats(6,5,0) = an65 - plus65 + , -1 + ansats(6,5,1) = plus65 + ansats(6,5,0) = an65 - plus65 ! 7s call sluggo (7, 0, varmax, varupp, varned, & ansats, org, lock(7,0), low, start(7,0)& - , stopp(7,0)) - do an70 = start(7,0), stopp(7,0), -1 - antel(7,0) = an70 + antel(6,5) + , stopp(7,0)) + do an70 = start(7,0), stopp(7,0), -1 + antel(7,0) = an70 + antel(6,5) if (.not.(antel(7,0)<=antal .and. ansats(6,& - 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle - ansats(7,0,0) = an70 + 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle + ansats(7,0,0) = an70 ! 7p call sluggo (7, 1, varmax, varupp, varned, & ansats, org, lock(7,1), low, start(7,1)& - , stopp(7,1)) - do an71 = start(7,1), stopp(7,1), -1 - antel(7,1) = an71 + antel(7,0) - if (antel(7,1) > antal) cycle + , stopp(7,1)) + do an71 = start(7,1), stopp(7,1), -1 + antel(7,1) = an71 + antel(7,0) + if (antel(7,1) > antal) cycle do plus71 = min(an71,4), max(an71 - 2,0), & - -1 - ansats(7,1,1) = plus71 - ansats(7,1,0) = an71 - plus71 + -1 + ansats(7,1,1) = plus71 + ansats(7,1,0) = an71 - plus71 ! 7d call sluggo (7, 2, varmax, varupp, varned, & ansats, org, lock(7,2), low, start(7,2)& - , stopp(7,2)) - do an72 = start(7,2), stopp(7,2), -1 - antel(7,2) = an72 + antel(7,1) - if (antel(7,2) > antal) cycle + , stopp(7,2)) + do an72 = start(7,2), stopp(7,2), -1 + antel(7,2) = an72 + antel(7,1) + if (antel(7,2) > antal) cycle do plus72 = min(an72,6), max(an72 - 4,0), & - -1 - ansats(7,2,1) = plus72 - ansats(7,2,0) = an72 - plus72 + -1 + ansats(7,2,1) = plus72 + ansats(7,2,0) = an72 - plus72 ! 7f call sluggo (7, 3, varmax, varupp, varned, & ansats, org, lock(7,3), low, start(7,3)& - , stopp(7,3)) - do an73 = start(7,3), stopp(7,3), -1 - antel(7,3) = an73 + antel(7,2) - if (antel(7,3) > antal) cycle + , stopp(7,3)) + do an73 = start(7,3), stopp(7,3), -1 + antel(7,3) = an73 + antel(7,2) + if (antel(7,3) > antal) cycle do plus73 = min(an73,8), max(an73 - 6,0), & - -1 - ansats(7,3,1) = plus73 - ansats(7,3,0) = an73 - plus73 + -1 + ansats(7,3,1) = plus73 + ansats(7,3,0) = an73 - plus73 ! 7g call sluggo (7, 4, varmax, varupp, varned, & ansats, org, lock(7,4), low, start(7,4)& - , stopp(7,4)) - do an74 = start(7,4), stopp(7,4), -1 - antel(7,4) = an74 + antel(7,3) - if (antel(7,4) > antal) cycle + , stopp(7,4)) + do an74 = start(7,4), stopp(7,4), -1 + antel(7,4) = an74 + antel(7,3) + if (antel(7,4) > antal) cycle do plus74 = min(an74,10), max(an74 - 8,0), & - -1 - ansats(7,4,1) = plus74 - ansats(7,4,0) = an74 - plus74 + -1 + ansats(7,4,1) = plus74 + ansats(7,4,0) = an74 - plus74 ! 7h call sluggo (7, 5, varmax, varupp, varned, & ansats, org, lock(7,5), low, start(7,5)& - , stopp(7,5)) - do an75 = start(7,5), stopp(7,5), -1 - antel(7,5) = an75 + antel(7,4) + , stopp(7,5)) + do an75 = start(7,5), stopp(7,5), -1 + antel(7,5) = an75 + antel(7,4) if (antel(7,5)>antal .or. ansats(7,4,1)>2) & - cycle + cycle do plus75 = min(an75,12), max(an75 - 10,0)& - , -1 - ansats(7,5,1) = plus75 - ansats(7,5,0) = an75 - plus75 + , -1 + ansats(7,5,1) = plus75 + ansats(7,5,0) = an75 - plus75 ! 7i call sluggo (7, 6, varmax, varupp, varned, & ansats, org, lock(7,6), low, start(7,6)& - , stopp(7,6)) - do an76 = start(7,6), stopp(7,6), -1 - antel(7,6) = an76 + antel(7,5) + , stopp(7,6)) + do an76 = start(7,6), stopp(7,6), -1 + antel(7,6) = an76 + antel(7,5) if (.not.(antel(7,6)<=antal .and. ansats(7,& 5,1)<=2 .and. ansats(7,5,0)<=2 .and. & - antel(7,6)>=lim(7))) cycle + antel(7,6)>=lim(7))) cycle do plus76 = min(an76,14), max(an76 - 12,0)& - , -1 - ansats(7,6,1) = plus76 - ansats(7,6,0) = an76 - plus76 + , -1 + ansats(7,6,1) = plus76 + ansats(7,6,0) = an76 - plus76 ! 8s call sluggo (8, 0, varmax, varupp, varned, & ansats, org, lock(8,0), low, start(8,0)& - , stopp(8,0)) - do an80 = start(8,0), stopp(8,0), -1 - antel(8,0) = an80 + antel(7,6) + , stopp(8,0)) + do an80 = start(8,0), stopp(8,0), -1 + antel(8,0) = an80 + antel(7,6) if (.not.(antel(8,0)<=antal .and. ansats(7,& - 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle - ansats(8,0,0) = an80 + 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle + ansats(8,0,0) = an80 ! 8p call sluggo (8, 1, varmax, varupp, varned, & ansats, org, lock(8,1), low, start(8,1)& - , stopp(8,1)) - do an81 = start(8,1), stopp(8,1), -1 - antel(8,1) = an81 + antel(8,0) - if (antel(8,1) > antal) cycle + , stopp(8,1)) + do an81 = start(8,1), stopp(8,1), -1 + antel(8,1) = an81 + antel(8,0) + if (antel(8,1) > antal) cycle do plus81 = min(an81,4), max(an81 - 2,0), & - -1 - ansats(8,1,1) = plus81 - ansats(8,1,0) = an81 - plus81 + -1 + ansats(8,1,1) = plus81 + ansats(8,1,0) = an81 - plus81 ! 8d call sluggo (8, 2, varmax, varupp, varned, & ansats, org, lock(8,2), low, start(8,2)& - , stopp(8,2)) - do an82 = start(8,2), stopp(8,2), -1 - antel(8,2) = an82 + antel(8,1) - if (antel(8,2) > antal) cycle + , stopp(8,2)) + do an82 = start(8,2), stopp(8,2), -1 + antel(8,2) = an82 + antel(8,1) + if (antel(8,2) > antal) cycle do plus82 = min(an82,6), max(an82 - 4,0), & - -1 - ansats(8,2,1) = plus82 - ansats(8,2,0) = an82 - plus82 + -1 + ansats(8,2,1) = plus82 + ansats(8,2,0) = an82 - plus82 ! 8f call sluggo (8, 3, varmax, varupp, varned, & ansats, org, lock(8,3), low, start(8,3)& - , stopp(8,3)) - do an83 = start(8,3), stopp(8,3), -1 - antel(8,3) = an83 + antel(8,2) - if (antel(8,3) > antal) cycle + , stopp(8,3)) + do an83 = start(8,3), stopp(8,3), -1 + antel(8,3) = an83 + antel(8,2) + if (antel(8,3) > antal) cycle do plus83 = min(an83,8), max(an83 - 6,0), & - -1 - ansats(8,3,1) = plus83 - ansats(8,3,0) = an83 - plus83 + -1 + ansats(8,3,1) = plus83 + ansats(8,3,0) = an83 - plus83 ! 8g call sluggo (8, 4, varmax, varupp, varned, & ansats, org, lock(8,4), low, start(8,4)& - , stopp(8,4)) - - do an84 = start(8,4), stopp(8,4), -1 - antel(8,4) = an84 + antel(8,3) - if (antel(8,4) > antal) cycle + , stopp(8,4)) + + do an84 = start(8,4), stopp(8,4), -1 + antel(8,4) = an84 + antel(8,3) + if (antel(8,4) > antal) cycle do plus84 = min(an84,10), max(an84 - 8,0), & - -1 - ansats(8,4,1) = plus84 - ansats(8,4,0) = an84 - plus84 + -1 + ansats(8,4,1) = plus84 + ansats(8,4,0) = an84 - plus84 ! 8h call sluggo (8, 5, varmax, varupp, varned, & ansats, org, lock(8,5), low, start(8,5)& - , stopp(8,5)) - do an85 = start(8,5), stopp(8,5), -1 - antel(8,5) = an85 + antel(8,4) + , stopp(8,5)) + do an85 = start(8,5), stopp(8,5), -1 + antel(8,5) = an85 + antel(8,4) if (antel(8,5)>antal .or. ansats(8,4,1)>2) & - cycle + cycle do plus85 = min(an85,12), max(an85 - 10,0)& - , -1 - ansats(8,5,1) = plus85 - ansats(8,5,0) = an85 - plus85 + , -1 + ansats(8,5,1) = plus85 + ansats(8,5,0) = an85 - plus85 ! 8i call sluggo (8, 6, varmax, varupp, varned, & ansats, org, lock(8,6), low, start(8,6)& - , stopp(8,6)) - do an86 = start(8,6), stopp(8,6), -1 - antel(8,6) = an86 + antel(8,5) + , stopp(8,6)) + do an86 = start(8,6), stopp(8,6), -1 + antel(8,6) = an86 + antel(8,5) if (.not.(antel(8,6)<=antal .and. ansats(8,& - 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle do plus86 = min(an86,14), max(an86 - 12,0)& - , -1 - ansats(8,6,1) = plus86 - ansats(8,6,0) = an86 - plus86 + , -1 + ansats(8,6,1) = plus86 + ansats(8,6,0) = an86 - plus86 ! 8k call sluggo (8, 7, varmax, varupp, varned, & ansats, org, lock(8,7), low, start(8,7)& - , stopp(8,7)) - do an87 = start(8,7), stopp(8,7), -1 - antel(8,7) = an87 + antel(8,6) + , stopp(8,7)) + do an87 = start(8,7), stopp(8,7), -1 + antel(8,7) = an87 + antel(8,6) if (.not.(antel(8,7)<=antal .and. ansats(8,& 6,1)<=2 .and. ansats(8,6,0)<=2 .and. & - antel(8,7)>=lim(8))) cycle + antel(8,7)>=lim(8))) cycle do plus87 = min(an87,16), max(an87 - 14,0)& - , -1 - ansats(8,7,1) = plus87 - ansats(8,7,0) = an87 - plus87 + , -1 + ansats(8,7,1) = plus87 + ansats(8,7,0) = an87 - plus87 ! 9s call sluggo (9, 0, varmax, varupp, varned, & ansats, org, lock(9,0), low, start(9,0)& - , stopp(9,0)) - do an90 = start(9,0), stopp(9,0), -1 - antel(9,0) = an90 + antel(8,7) + , stopp(9,0)) + do an90 = start(9,0), stopp(9,0), -1 + antel(9,0) = an90 + antel(8,7) if (.not.(antel(9,0)<=antal .and. ansats(8,& - 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle - ansats(9,0,0) = an90 + 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle + ansats(9,0,0) = an90 ! 9p call sluggo (9, 1, varmax, varupp, varned, & ansats, org, lock(9,1), low, start(9,1)& - , stopp(9,1)) - do an91 = start(9,1), stopp(9,1), -1 - antel(9,1) = an91 + antel(9,0) - if (antel(9,1) > antal) cycle + , stopp(9,1)) + do an91 = start(9,1), stopp(9,1), -1 + antel(9,1) = an91 + antel(9,0) + if (antel(9,1) > antal) cycle do plus91 = min(an91,4), max(an91 - 2,0), & - -1 - ansats(9,1,1) = plus91 - ansats(9,1,0) = an91 - plus91 + -1 + ansats(9,1,1) = plus91 + ansats(9,1,0) = an91 - plus91 ! 9d call sluggo (9, 2, varmax, varupp, varned, & ansats, org, lock(9,2), low, start(9,2)& - , stopp(9,2)) - do an92 = start(9,2), stopp(9,2), -1 - antel(9,2) = an92 + antel(9,1) - if (antel(9,2) > antal) cycle + , stopp(9,2)) + do an92 = start(9,2), stopp(9,2), -1 + antel(9,2) = an92 + antel(9,1) + if (antel(9,2) > antal) cycle do plus92 = min(an92,6), max(an92 - 4,0), & - -1 - ansats(9,2,1) = plus92 - ansats(9,2,0) = an92 - plus92 + -1 + ansats(9,2,1) = plus92 + ansats(9,2,0) = an92 - plus92 ! 9f call sluggo (9, 3, varmax, varupp, varned, & ansats, org, lock(9,3), low, start(9,3)& - , stopp(9,3)) - do an93 = start(9,3), stopp(9,3), -1 - antel(9,3) = an93 + antel(9,2) - if (antel(9,3) > antal) cycle + , stopp(9,3)) + do an93 = start(9,3), stopp(9,3), -1 + antel(9,3) = an93 + antel(9,2) + if (antel(9,3) > antal) cycle do plus93 = min(an93,8), max(an93 - 6,0), & - -1 - ansats(9,3,1) = plus93 - ansats(9,3,0) = an93 - plus93 + -1 + ansats(9,3,1) = plus93 + ansats(9,3,0) = an93 - plus93 ! 9g call sluggo (9, 4, varmax, varupp, varned, & ansats, org, lock(9,4), low, start(9,4)& - , stopp(9,4)) - do an94 = start(9,4), stopp(9,4), -1 - antel(9,4) = an94 + antel(9,3) - if (antel(9,4) > antal) cycle + , stopp(9,4)) + do an94 = start(9,4), stopp(9,4), -1 + antel(9,4) = an94 + antel(9,3) + if (antel(9,4) > antal) cycle do plus94 = min(an94,10), max(an94 - 8,0), & - -1 - ansats(9,4,1) = plus94 - ansats(9,4,0) = an94 - plus94 + -1 + ansats(9,4,1) = plus94 + ansats(9,4,0) = an94 - plus94 ! 9h call sluggo (9, 5, varmax, varupp, varned, & ansats, org, lock(9,5), low, start(9,5)& - , stopp(9,5)) - do an95 = start(9,5), stopp(9,5), -1 - antel(9,5) = an95 + antel(9,4) + , stopp(9,5)) + do an95 = start(9,5), stopp(9,5), -1 + antel(9,5) = an95 + antel(9,4) if (antel(9,5)>antal .or. ansats(9,4,1)>2) & - cycle + cycle do plus95 = min(an95,12), max(an95 - 10,0)& - , -1 - ansats(9,5,1) = plus95 - ansats(9,5,0) = an95 - plus95 + , -1 + ansats(9,5,1) = plus95 + ansats(9,5,0) = an95 - plus95 ! 9i call sluggo (9, 6, varmax, varupp, varned, & ansats, org, lock(9,6), low, start(9,6)& - , stopp(9,6)) - do an96 = start(9,6), stopp(9,6), -1 - antel(9,6) = an96 + antel(9,5) + , stopp(9,6)) + do an96 = start(9,6), stopp(9,6), -1 + antel(9,6) = an96 + antel(9,5) if (.not.(antel(9,6)<=antal .and. ansats(9,& - 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle do plus96 = min(an96,14), max(an96 - 12,0)& - , -1 - ansats(9,6,1) = plus96 - ansats(9,6,0) = an96 - plus96 + , -1 + ansats(9,6,1) = plus96 + ansats(9,6,0) = an96 - plus96 ! 9k call sluggo (9, 7, varmax, varupp, varned, & ansats, org, lock(9,7), low, start(9,7)& - , stopp(9,7)) - do an97 = start(9,7), stopp(9,7), -1 - antel(9,7) = an97 + antel(9,6) + , stopp(9,7)) + do an97 = start(9,7), stopp(9,7), -1 + antel(9,7) = an97 + antel(9,6) if (.not.(antel(9,7)<=antal .and. ansats(9,& - 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle + 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle do plus97 = min(an97,16), max(an97 - 14,0)& - , -1 - ansats(9,7,1) = plus97 - ansats(9,7,0) = an97 - plus97 + , -1 + ansats(9,7,1) = plus97 + ansats(9,7,0) = an97 - plus97 ! 9l call sluggo (9, 8, varmax, varupp, varned, & ansats, org, lock(9,8), low, start(9,8)& - , stopp(9,8)) - do an98 = start(9,8), stopp(9,8), -1 - antel(9,8) = an98 + antel(9,7) + , stopp(9,8)) + do an98 = start(9,8), stopp(9,8), -1 + antel(9,8) = an98 + antel(9,7) if (.not.(antel(9,8)<=antal .and. ansats(9,& 7,1)<=2 .and. ansats(9,7,0)<=2 .and. & - antel(9,8)>=lim(9))) cycle + antel(9,8)>=lim(9))) cycle do plus98 = min(an98,18), max(an98 - 16,0)& - , -1 - ansats(9,8,1) = plus98 - ansats(9,8,0) = an98 - plus98 + , -1 + ansats(9,8,1) = plus98 + ansats(9,8,0) = an98 - plus98 ! 10s call sluggo (10, 0, varmax, varupp, varned& , ansats, org, lock(10,0), low, start(10& - ,0), stopp(10,0)) - do ana0 = start(10,0), stopp(10,0), -1 - antel(10,0) = ana0 + antel(9,8) + ,0), stopp(10,0)) + do ana0 = start(10,0), stopp(10,0), -1 + antel(10,0) = ana0 + antel(9,8) if (.not.(antel(10,0)<=antal .and. ansats(9& - ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle - ansats(10,0,0) = ana0 + ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle + ansats(10,0,0) = ana0 ! 10p call sluggo (10, 1, varmax, varupp, varned& , ansats, org, lock(10,1), low, start(10& - ,1), stopp(10,1)) - do ana1 = start(10,1), stopp(10,1), -1 - antel(10,1) = ana1 + antel(10,0) - if (antel(10,1) > antal) cycle + ,1), stopp(10,1)) + do ana1 = start(10,1), stopp(10,1), -1 + antel(10,1) = ana1 + antel(10,0) + if (antel(10,1) > antal) cycle do plusa1 = min(ana1,4), max(ana1 - 2,0), & - -1 - ansats(10,1,1) = plusa1 - ansats(10,1,0) = ana1 - plusa1 + -1 + ansats(10,1,1) = plusa1 + ansats(10,1,0) = ana1 - plusa1 ! 10d call sluggo (10, 2, varmax, varupp, varned& , ansats, org, lock(10,2), low, start(10& - ,2), stopp(10,2)) - do ana2 = start(10,2), stopp(10,2), -1 - antel(10,2) = ana2 + antel(10,1) - if (antel(10,2) > antal) cycle + ,2), stopp(10,2)) + do ana2 = start(10,2), stopp(10,2), -1 + antel(10,2) = ana2 + antel(10,1) + if (antel(10,2) > antal) cycle do plusa2 = min(ana2,6), max(ana2 - 4,0), & - -1 - ansats(10,2,1) = plusa2 - ansats(10,2,0) = ana2 - plusa2 + -1 + ansats(10,2,1) = plusa2 + ansats(10,2,0) = ana2 - plusa2 ! 10f call sluggo (10, 3, varmax, varupp, varned& , ansats, org, lock(10,3), low, start(10& - ,3), stopp(10,3)) - do ana3 = start(10,3), stopp(10,3), -1 - antel(10,3) = ana3 + antel(10,2) - if (antel(10,3) > antal) cycle + ,3), stopp(10,3)) + do ana3 = start(10,3), stopp(10,3), -1 + antel(10,3) = ana3 + antel(10,2) + if (antel(10,3) > antal) cycle do plusa3 = min(ana3,8), max(ana3 - 6,0), & - -1 - ansats(10,3,1) = plusa3 - ansats(10,3,0) = ana3 - plusa3 + -1 + ansats(10,3,1) = plusa3 + ansats(10,3,0) = ana3 - plusa3 ! 10g call sluggo (10, 4, varmax, varupp, varned& , ansats, org, lock(10,4), low, start(10& - ,4), stopp(10,4)) - do ana4 = start(10,4), stopp(10,4), -1 - antel(10,4) = ana4 + antel(10,3) - if (antel(10,4) > antal) cycle + ,4), stopp(10,4)) + do ana4 = start(10,4), stopp(10,4), -1 + antel(10,4) = ana4 + antel(10,3) + if (antel(10,4) > antal) cycle do plusa4 = min(ana4,10), max(ana4 - 8,0), & - -1 - ansats(10,4,1) = plusa4 - ansats(10,4,0) = ana4 - plusa4 + -1 + ansats(10,4,1) = plusa4 + ansats(10,4,0) = ana4 - plusa4 ! 10h call sluggo (10, 5, varmax, varupp, varned& , ansats, org, lock(10,5), low, start(10& - ,5), stopp(10,5)) - do ana5 = start(10,5), stopp(10,5), -1 - antel(10,5) = ana5 + antel(10,4) + ,5), stopp(10,5)) + do ana5 = start(10,5), stopp(10,5), -1 + antel(10,5) = ana5 + antel(10,4) if (antel(10,5)>antal .or. ansats(10,4,1)>2& - ) cycle + ) cycle do plusa5 = min(ana5,12), max(ana5 - 10,0)& - , -1 - ansats(10,5,1) = plusa5 - ansats(10,5,0) = ana5 - plusa5 + , -1 + ansats(10,5,1) = plusa5 + ansats(10,5,0) = ana5 - plusa5 ! 10i call sluggo (10, 6, varmax, varupp, varned& , ansats, org, lock(10,6), low, start(10& - ,6), stopp(10,6)) - do ana6 = start(10,6), stopp(10,6), -1 - antel(10,6) = ana6 + antel(10,5) + ,6), stopp(10,6)) + do ana6 = start(10,6), stopp(10,6), -1 + antel(10,6) = ana6 + antel(10,5) if (.not.(antel(10,6)<=antal .and. ansats(& 10,5,1)<=2 .and. ansats(10,5,0)<=2)) & - cycle + cycle do plusa6 = min(ana6,14), max(ana6 - 12,0)& - , -1 - ansats(10,6,1) = plusa6 - ansats(10,6,0) = ana6 - plusa6 + , -1 + ansats(10,6,1) = plusa6 + ansats(10,6,0) = ana6 - plusa6 ! 10k call sluggo (10, 7, varmax, varupp, varned& , ansats, org, lock(10,7), low, start(10& - ,7), stopp(10,7)) - do ana7 = start(10,7), stopp(10,7), -1 - antel(10,7) = ana7 + antel(10,6) + ,7), stopp(10,7)) + do ana7 = start(10,7), stopp(10,7), -1 + antel(10,7) = ana7 + antel(10,6) if (.not.(antel(10,7)<=antal .and. ansats(& 10,6,1)<=2 .and. ansats(10,6,0)<=2)) & - cycle + cycle do plusa7 = min(ana7,16), max(ana7 - 14,0)& - , -1 - ansats(10,7,1) = plusa7 - ansats(10,7,0) = ana7 - plusa7 + , -1 + ansats(10,7,1) = plusa7 + ansats(10,7,0) = ana7 - plusa7 ! 10l call sluggo (10, 8, varmax, varupp, varned& , ansats, org, lock(10,8), low, start(10& - ,8), stopp(10,8)) - do ana8 = start(10,8), stopp(10,8), -1 - antel(10,8) = ana8 + antel(10,7) + ,8), stopp(10,8)) + do ana8 = start(10,8), stopp(10,8), -1 + antel(10,8) = ana8 + antel(10,7) if (.not.(antel(10,8)<=antal .and. ansats(& 10,7,1)<=2 .and. ansats(10,7,0)<=2)) & - cycle + cycle do plusa8 = min(ana8,18), max(ana8 - 16,0)& - , -1 - ansats(10,8,1) = plusa8 - ansats(10,8,0) = ana8 - plusa8 + , -1 + ansats(10,8,1) = plusa8 + ansats(10,8,0) = ana8 - plusa8 ! 10m call sluggo (10, 9, varmax, varupp, varned& , ansats, org, lock(10,9), low, start(10& - ,9), stopp(10,9)) - do ana9 = start(10,9), stopp(10,9), -1 - antel(10,9) = ana9 + antel(10,8) + ,9), stopp(10,9)) + do ana9 = start(10,9), stopp(10,9), -1 + antel(10,9) = ana9 + antel(10,8) if (.not.(antel(10,9)<=antal .and. ansats(& 10,8,1)<=2 .and. ansats(10,8,0)<=2& - .and. antel(10,9)>=lim(10))) cycle + .and. antel(10,9)>=lim(10))) cycle do plusa9 = min(ana9,20), max(ana9 - 18,0)& - , -1 - ansats(10,9,1) = plusa9 - ansats(10,9,0) = ana9 - plusa9 + , -1 + ansats(10,9,1) = plusa9 + ansats(10,9,0) = ana9 - plusa9 ! 11s call sluggo (11, 0, varmax, varupp, varned& , ansats, org, lock(11,0), low, start(11& - ,0), stopp(11,0)) - do anb0 = start(11,0), stopp(11,0), -1 - antel(11,0) = anb0 + antel(10,9) + ,0), stopp(11,0)) + do anb0 = start(11,0), stopp(11,0), -1 + antel(11,0) = anb0 + antel(10,9) if (.not.(antel(11,0)<=antal .and. ansats(& 10,9,1)<=2 .and. ansats(10,9,0)<=2)) & - cycle - ansats(11,0,0) = anb0 + cycle + ansats(11,0,0) = anb0 ! 11p call sluggo (11, 1, varmax, varupp, varned& , ansats, org, lock(11,1), low, start(11& - ,1), stopp(11,1)) - do anb1 = start(11,1), stopp(11,1), -1 - antel(11,1) = anb1 + antel(11,0) - if (antel(11,1) > antal) cycle + ,1), stopp(11,1)) + do anb1 = start(11,1), stopp(11,1), -1 + antel(11,1) = anb1 + antel(11,0) + if (antel(11,1) > antal) cycle do plusb1 = min(anb1,4), max(anb1 - 2,0), & - -1 - ansats(11,1,1) = plusb1 - ansats(11,1,0) = anb1 - plusb1 + -1 + ansats(11,1,1) = plusb1 + ansats(11,1,0) = anb1 - plusb1 ! 11d call sluggo (11, 2, varmax, varupp, varned& , ansats, org, lock(11,2), low, start(11& - ,2), stopp(11,2)) - do anb2 = start(11,2), stopp(11,2), -1 - antel(11,2) = anb2 + antel(11,1) - if (antel(11,2) > antal) cycle + ,2), stopp(11,2)) + do anb2 = start(11,2), stopp(11,2), -1 + antel(11,2) = anb2 + antel(11,1) + if (antel(11,2) > antal) cycle do plusb2 = min(anb2,6), max(anb2 - 4,0), & - -1 - ansats(11,2,1) = plusb2 - ansats(11,2,0) = anb2 - plusb2 + -1 + ansats(11,2,1) = plusb2 + ansats(11,2,0) = anb2 - plusb2 ! 11f call sluggo (11, 3, varmax, varupp, varned& , ansats, org, lock(11,3), low, start(11& - ,3), stopp(11,3)) - do anb3 = start(11,3), stopp(11,3), -1 - antel(11,3) = anb3 + antel(11,2) - if (antel(11,3) > antal) cycle + ,3), stopp(11,3)) + do anb3 = start(11,3), stopp(11,3), -1 + antel(11,3) = anb3 + antel(11,2) + if (antel(11,3) > antal) cycle do plusb3 = min(anb3,8), max(anb3 - 6,0), & - -1 - ansats(11,3,1) = plusb3 - ansats(11,3,0) = anb3 - plusb3 + -1 + ansats(11,3,1) = plusb3 + ansats(11,3,0) = anb3 - plusb3 ! 11g call sluggo (11, 4, varmax, varupp, varned& , ansats, org, lock(11,4), low, start(11& - ,4), stopp(11,4)) - do anb4 = start(11,4), stopp(11,4), -1 - antel(11,4) = anb4 + antel(11,3) - if (antel(11,4) > antal) cycle + ,4), stopp(11,4)) + do anb4 = start(11,4), stopp(11,4), -1 + antel(11,4) = anb4 + antel(11,3) + if (antel(11,4) > antal) cycle do plusb4 = min(anb4,10), max(anb4 - 8,0), & - -1 - ansats(11,4,1) = plusb4 - ansats(11,4,0) = anb4 - plusb4 + -1 + ansats(11,4,1) = plusb4 + ansats(11,4,0) = anb4 - plusb4 ! 11h call sluggo (11, 5, varmax, varupp, varned& , ansats, org, lock(11,5), low, start(11& - ,5), stopp(11,5)) - do anb5 = start(11,5), stopp(11,5), -1 - antel(11,5) = anb5 + antel(11,4) + ,5), stopp(11,5)) + do anb5 = start(11,5), stopp(11,5), -1 + antel(11,5) = anb5 + antel(11,4) if (antel(11,5)>antal .or. ansats(11,4,1)>2& - ) cycle + ) cycle do plusb5 = min(anb5,12), max(anb5 - 10,0)& - , -1 - ansats(11,5,1) = plusb5 - ansats(11,5,0) = anb5 - plusb5 + , -1 + ansats(11,5,1) = plusb5 + ansats(11,5,0) = anb5 - plusb5 ! 11i call sluggo (11, 6, varmax, varupp, varned& , ansats, org, lock(11,6), low, start(11& - ,6), stopp(11,6)) - do anb6 = start(11,6), stopp(11,6), -1 - antel(11,6) = anb6 + antel(11,5) + ,6), stopp(11,6)) + do anb6 = start(11,6), stopp(11,6), -1 + antel(11,6) = anb6 + antel(11,5) if (.not.(antel(11,6)<=antal .and. ansats(& 11,5,1)<=2 .and. ansats(11,5,0)<=2)) & - cycle + cycle do plusb6 = min(anb6,14), max(anb6 - 12,0)& - , -1 - ansats(11,6,1) = plusb6 - ansats(11,6,0) = anb6 - plusb6 + , -1 + ansats(11,6,1) = plusb6 + ansats(11,6,0) = anb6 - plusb6 ! 11k call sluggo (11, 7, varmax, varupp, varned& , ansats, org, lock(11,7), low, start(11& - ,7), stopp(11,7)) - do anb7 = start(11,7), stopp(11,7), -1 - antel(11,7) = anb7 + antel(11,6) + ,7), stopp(11,7)) + do anb7 = start(11,7), stopp(11,7), -1 + antel(11,7) = anb7 + antel(11,6) if (.not.(antel(11,7)<=antal .and. ansats(& 11,6,1)<=2 .and. ansats(11,6,0)<=2)) & - cycle + cycle do plusb7 = min(anb7,16), max(anb7 - 14,0)& - , -1 - ansats(11,7,1) = plusb7 - ansats(11,7,0) = anb7 - plusb7 + , -1 + ansats(11,7,1) = plusb7 + ansats(11,7,0) = anb7 - plusb7 ! 11l call sluggo (11, 8, varmax, varupp, varned& , ansats, org, lock(11,8), low, start(11& - ,8), stopp(11,8)) - do anb8 = start(11,8), stopp(11,8), -1 - antel(11,8) = anb8 + antel(11,7) + ,8), stopp(11,8)) + do anb8 = start(11,8), stopp(11,8), -1 + antel(11,8) = anb8 + antel(11,7) if (.not.(antel(11,8)<=antal .and. ansats(& 11,7,1)<=2 .and. ansats(11,7,0)<=2)) & - cycle + cycle do plusb8 = min(anb8,18), max(anb8 - 16,0)& - , -1 - ansats(11,8,1) = plusb8 - ansats(11,8,0) = anb8 - plusb8 + , -1 + ansats(11,8,1) = plusb8 + ansats(11,8,0) = anb8 - plusb8 ! 11m call sluggo (11, 9, varmax, varupp, varned& , ansats, org, lock(11,9), low, start(11& - ,9), stopp(11,9)) - do anb9 = start(11,9), stopp(11,9), -1 - antel(11,9) = anb9 + antel(11,8) + ,9), stopp(11,9)) + do anb9 = start(11,9), stopp(11,9), -1 + antel(11,9) = anb9 + antel(11,8) if (.not.(antel(11,9)<=antal .and. ansats(& 11,8,1)<=2 .and. ansats(11,8,0)<=2)) & - cycle + cycle do plusb9 = min(anb9,20), max(anb9 - 18,0)& - , -1 - ansats(11,9,1) = plusb9 - ansats(11,9,0) = anb9 - plusb9 + , -1 + ansats(11,9,1) = plusb9 + ansats(11,9,0) = anb9 - plusb9 ! 11n call sluggo (11, 10, varmax, varupp, varned& , ansats, org, lock(11,10), low, start(& - 11,10), stopp(11,10)) - do anba = start(11,10), stopp(11,10), -1 - antel(11,10) = anba + antel(11,9) + 11,10), stopp(11,10)) + do anba = start(11,10), stopp(11,10), -1 + antel(11,10) = anba + antel(11,9) if (.not.(antel(11,10)<=antal .and. ansats(& 11,9,1)<=2 .and. ansats(11,9,0)<=2& - .and. antel(11,10)>=lim(11))) cycle + .and. antel(11,10)>=lim(11))) cycle do plusba = min(anba,22), max(anba - 20,0)& - , -1 - ansats(11,10,1) = plusba - ansats(11,10,0) = anba - plusba + , -1 + ansats(11,10,1) = plusba + ansats(11,10,0) = anba - plusba ! 12s call sluggo (12, 0, varmax, varupp, varned& , ansats, org, lock(12,0), low, start(12& - ,0), stopp(12,0)) - do anc0 = start(12,0), stopp(12,0), -1 - antel(12,0) = anc0 + antel(11,10) + ,0), stopp(12,0)) + do anc0 = start(12,0), stopp(12,0), -1 + antel(12,0) = anc0 + antel(11,10) if (.not.(antel(12,0)<=antal .and. ansats(& 11,10,1)<=2 .and. ansats(11,10,0)<=2)) & - cycle - ansats(12,0,0) = anc0 + cycle + ansats(12,0,0) = anc0 ! 12p call sluggo (12, 1, varmax, varupp, varned& , ansats, org, lock(12,1), low, start(12& - ,1), stopp(12,1)) - do anc1 = start(12,1), stopp(12,1), -1 - antel(12,1) = anc1 + antel(12,0) - if (antel(12,1) > antal) cycle + ,1), stopp(12,1)) + do anc1 = start(12,1), stopp(12,1), -1 + antel(12,1) = anc1 + antel(12,0) + if (antel(12,1) > antal) cycle do plusc1 = min(anc1,4), max(anc1 - 2,0), & - -1 - ansats(12,1,1) = plusc1 - ansats(12,1,0) = anc1 - plusc1 + -1 + ansats(12,1,1) = plusc1 + ansats(12,1,0) = anc1 - plusc1 ! 12d call sluggo (12, 2, varmax, varupp, varned& , ansats, org, lock(12,2), low, start(12& - ,2), stopp(12,2)) - do anc2 = start(12,2), stopp(12,2), -1 - antel(12,2) = anc2 + antel(12,1) - if (antel(12,2) > antal) cycle + ,2), stopp(12,2)) + do anc2 = start(12,2), stopp(12,2), -1 + antel(12,2) = anc2 + antel(12,1) + if (antel(12,2) > antal) cycle do plusc2 = min(anc2,6), max(anc2 - 4,0), & - -1 - ansats(12,2,1) = plusc2 - ansats(12,2,0) = anc2 - plusc2 + -1 + ansats(12,2,1) = plusc2 + ansats(12,2,0) = anc2 - plusc2 ! 12f call sluggo (12, 3, varmax, varupp, varned& , ansats, org, lock(12,3), low, start(12& - ,3), stopp(12,3)) - do anc3 = start(12,3), stopp(12,3), -1 - antel(12,3) = anc3 + antel(12,2) - if (antel(12,3) > antal) cycle + ,3), stopp(12,3)) + do anc3 = start(12,3), stopp(12,3), -1 + antel(12,3) = anc3 + antel(12,2) + if (antel(12,3) > antal) cycle do plusc3 = min(anc3,8), max(anc3 - 6,0), & - -1 - ansats(12,3,1) = plusc3 - ansats(12,3,0) = anc3 - plusc3 + -1 + ansats(12,3,1) = plusc3 + ansats(12,3,0) = anc3 - plusc3 ! 12g call sluggo (12, 4, varmax, varupp, varned& , ansats, org, lock(12,4), low, start(12& - ,4), stopp(12,4)) - do anc4 = start(12,4), stopp(12,4), -1 - antel(12,4) = anc4 + antel(12,3) - if (antel(12,4) > antal) cycle + ,4), stopp(12,4)) + do anc4 = start(12,4), stopp(12,4), -1 + antel(12,4) = anc4 + antel(12,3) + if (antel(12,4) > antal) cycle do plusc4 = min(anc4,10), max(anc4 - 8,0), & - -1 - ansats(12,4,1) = plusc4 - ansats(12,4,0) = anc4 - plusc4 + -1 + ansats(12,4,1) = plusc4 + ansats(12,4,0) = anc4 - plusc4 ! 12h call sluggo (12, 5, varmax, varupp, varned& , ansats, org, lock(12,5), low, start(12& - ,5), stopp(12,5)) - do anc5 = start(12,5), stopp(12,5), -1 - antel(12,5) = anc5 + antel(12,4) + ,5), stopp(12,5)) + do anc5 = start(12,5), stopp(12,5), -1 + antel(12,5) = anc5 + antel(12,4) if (antel(12,5)>antal .or. ansats(12,4,1)>2& - ) cycle + ) cycle do plusc5 = min(anc5,12), max(anc5 - 10,0)& - , -1 - ansats(12,5,1) = plusc5 - ansats(12,5,0) = anc5 - plusc5 + , -1 + ansats(12,5,1) = plusc5 + ansats(12,5,0) = anc5 - plusc5 ! 12i call sluggo (12, 6, varmax, varupp, varned& , ansats, org, lock(12,6), low, start(12& - ,6), stopp(12,6)) - do anc6 = start(12,6), stopp(12,6), -1 - antel(12,6) = anc6 + antel(12,5) + ,6), stopp(12,6)) + do anc6 = start(12,6), stopp(12,6), -1 + antel(12,6) = anc6 + antel(12,5) if (.not.(antel(12,6)<=antal .and. ansats(& 12,5,1)<=2 .and. ansats(12,5,0)<=2)) & - cycle + cycle do plusc6 = min(anc6,14), max(anc6 - 12,0)& - , -1 - ansats(12,6,1) = plusc6 - ansats(12,6,0) = anc6 - plusc6 + , -1 + ansats(12,6,1) = plusc6 + ansats(12,6,0) = anc6 - plusc6 ! 12k call sluggo (12, 7, varmax, varupp, varned& , ansats, org, lock(12,7), low, start(12& - ,7), stopp(12,7)) - do anc7 = start(12,7), stopp(12,7), -1 - antel(12,7) = anc7 + antel(12,6) + ,7), stopp(12,7)) + do anc7 = start(12,7), stopp(12,7), -1 + antel(12,7) = anc7 + antel(12,6) if (.not.(antel(12,7)<=antal .and. ansats(& 12,6,1)<=2 .and. ansats(12,6,0)<=2)) & - cycle + cycle do plusc7 = min(anc7,16), max(anc7 - 14,0)& - , -1 - ansats(12,7,1) = plusc7 - ansats(12,7,0) = anc7 - plusc7 + , -1 + ansats(12,7,1) = plusc7 + ansats(12,7,0) = anc7 - plusc7 ! 12l call sluggo (12, 8, varmax, varupp, varned& , ansats, org, lock(12,8), low, start(12& - ,8), stopp(12,8)) - do anc8 = start(12,8), stopp(12,8), -1 - antel(12,8) = anc8 + antel(12,7) + ,8), stopp(12,8)) + do anc8 = start(12,8), stopp(12,8), -1 + antel(12,8) = anc8 + antel(12,7) if (.not.(antel(12,8)<=antal .and. ansats(& 12,7,1)<=2 .and. ansats(12,7,0)<=2)) & - cycle + cycle do plusc8 = min(anc8,18), max(anc8 - 16,0)& - , -1 - ansats(12,8,1) = plusc8 - ansats(12,8,0) = anc8 - plusc8 + , -1 + ansats(12,8,1) = plusc8 + ansats(12,8,0) = anc8 - plusc8 ! 12m call sluggo (12, 9, varmax, varupp, varned& , ansats, org, lock(12,9), low, start(12& - ,9), stopp(12,9)) - do anc9 = start(12,9), stopp(12,9), -1 - antel(12,9) = anc9 + antel(12,8) + ,9), stopp(12,9)) + do anc9 = start(12,9), stopp(12,9), -1 + antel(12,9) = anc9 + antel(12,8) if (.not.(antel(12,9)<=antal .and. ansats(& 12,8,1)<=2 .and. ansats(12,8,0)<=2)) & - cycle + cycle do plusc9 = min(anc9,20), max(anc9 - 18,0)& - , -1 - ansats(12,9,1) = plusc9 - ansats(12,9,0) = anc9 - plusc9 + , -1 + ansats(12,9,1) = plusc9 + ansats(12,9,0) = anc9 - plusc9 ! 12n call sluggo (12, 10, varmax, varupp, varned& , ansats, org, lock(12,10), low, start(& - 12,10), stopp(12,10)) - do anca = start(12,10), stopp(12,10), -1 - antel(12,10) = anca + antel(12,9) + 12,10), stopp(12,10)) + do anca = start(12,10), stopp(12,10), -1 + antel(12,10) = anca + antel(12,9) if (.not.(antel(12,10)<=antal .and. ansats(& 12,9,1)<=2 .and. ansats(12,9,0)<=2& - .and. antel(12,10)>=lim(12))) cycle + .and. antel(12,10)>=lim(12))) cycle do plusca = min(anca,22), max(anca - 20,0)& - , -1 - ansats(12,10,1) = plusca - ansats(12,10,0) = anca - plusca + , -1 + ansats(12,10,1) = plusca + ansats(12,10,0) = anca - plusca ! 13s call sluggo (13, 0, varmax, varupp, varned& , ansats, org, lock(13,0), low, start(13& - ,0), stopp(13,0)) - do and0 = start(13,0), stopp(13,0), -1 - antel(13,0) = and0 + antel(12,10) + ,0), stopp(13,0)) + do and0 = start(13,0), stopp(13,0), -1 + antel(13,0) = and0 + antel(12,10) if (.not.(antel(13,0)<=antal .and. ansats(& 12,10,1)<=2 .and. ansats(12,10,0)<=2)) & - cycle - ansats(13,0,0) = and0 + cycle + ansats(13,0,0) = and0 ! 13p call sluggo (13, 1, varmax, varupp, varned& , ansats, org, lock(13,1), low, start(13& - ,1), stopp(13,1)) - do and1 = start(13,1), stopp(13,1), -1 - antel(13,1) = and1 + antel(13,0) - if (antel(13,1) > antal) cycle + ,1), stopp(13,1)) + do and1 = start(13,1), stopp(13,1), -1 + antel(13,1) = and1 + antel(13,0) + if (antel(13,1) > antal) cycle do plusd1 = min(and1,4), max(and1 - 2,0), & - -1 - ansats(13,1,1) = plusd1 - ansats(13,1,0) = and1 - plusd1 + -1 + ansats(13,1,1) = plusd1 + ansats(13,1,0) = and1 - plusd1 ! 13d call sluggo (13, 2, varmax, varupp, varned& , ansats, org, lock(13,2), low, start(13& - ,2), stopp(13,2)) - do and2 = start(13,2), stopp(13,2), -1 - antel(13,2) = and2 + antel(13,1) - if (antel(13,2) > antal) cycle + ,2), stopp(13,2)) + do and2 = start(13,2), stopp(13,2), -1 + antel(13,2) = and2 + antel(13,1) + if (antel(13,2) > antal) cycle do plusd2 = min(and2,6), max(and2 - 4,0), & - -1 - ansats(13,2,1) = plusd2 - ansats(13,2,0) = and2 - plusd2 + -1 + ansats(13,2,1) = plusd2 + ansats(13,2,0) = and2 - plusd2 ! 13f call sluggo (13, 3, varmax, varupp, varned& , ansats, org, lock(13,3), low, start(13& - ,3), stopp(13,3)) - do and3 = start(13,3), stopp(13,3), -1 - antel(13,3) = and3 + antel(13,2) - if (antel(13,3) > antal) cycle + ,3), stopp(13,3)) + do and3 = start(13,3), stopp(13,3), -1 + antel(13,3) = and3 + antel(13,2) + if (antel(13,3) > antal) cycle do plusd3 = min(and3,8), max(and3 - 6,0), & - -1 - ansats(13,3,1) = plusd3 - ansats(13,3,0) = and3 - plusd3 + -1 + ansats(13,3,1) = plusd3 + ansats(13,3,0) = and3 - plusd3 ! 13g call sluggo (13, 4, varmax, varupp, varned& , ansats, org, lock(13,4), low, start(13& - ,4), stopp(13,4)) - do and4 = start(13,4), stopp(13,4), -1 - antel(13,4) = and4 + antel(13,3) - if (antel(13,4) > antal) cycle + ,4), stopp(13,4)) + do and4 = start(13,4), stopp(13,4), -1 + antel(13,4) = and4 + antel(13,3) + if (antel(13,4) > antal) cycle do plusd4 = min(and4,10), max(and4 - 8,0), & - -1 - ansats(13,4,1) = plusd4 - ansats(13,4,0) = and4 - plusd4 + -1 + ansats(13,4,1) = plusd4 + ansats(13,4,0) = and4 - plusd4 ! 13h call sluggo (13, 5, varmax, varupp, varned& , ansats, org, lock(13,5), low, start(13& - ,5), stopp(13,5)) - do and5 = start(13,5), stopp(13,5), -1 - antel(13,5) = and5 + antel(13,4) + ,5), stopp(13,5)) + do and5 = start(13,5), stopp(13,5), -1 + antel(13,5) = and5 + antel(13,4) if (antel(13,5)>antal .or. ansats(13,4,1)>2& - ) cycle + ) cycle do plusd5 = min(and5,12), max(and5 - 10,0)& - , -1 - ansats(13,5,1) = plusd5 - ansats(13,5,0) = and5 - plusd5 + , -1 + ansats(13,5,1) = plusd5 + ansats(13,5,0) = and5 - plusd5 ! 13i call sluggo (13, 6, varmax, varupp, varned& , ansats, org, lock(13,6), low, start(13& - ,6), stopp(13,6)) - do and6 = start(13,6), stopp(13,6), -1 - antel(13,6) = and6 + antel(13,5) + ,6), stopp(13,6)) + do and6 = start(13,6), stopp(13,6), -1 + antel(13,6) = and6 + antel(13,5) if (.not.(antel(13,6)<=antal .and. ansats(& 13,5,1)<=2 .and. ansats(13,5,0)<=2)) & - cycle + cycle do plusd6 = min(and6,14), max(and6 - 12,0)& - , -1 - ansats(13,6,1) = plusd6 - ansats(13,6,0) = and6 - plusd6 + , -1 + ansats(13,6,1) = plusd6 + ansats(13,6,0) = and6 - plusd6 ! 13k call sluggo (13, 7, varmax, varupp, varned& , ansats, org, lock(13,7), low, start(13& - ,7), stopp(13,7)) - do and7 = start(13,7), stopp(13,7), -1 - antel(13,7) = and7 + antel(13,6) + ,7), stopp(13,7)) + do and7 = start(13,7), stopp(13,7), -1 + antel(13,7) = and7 + antel(13,6) if (.not.(antel(13,7)<=antal .and. ansats(& 13,6,1)<=2 .and. ansats(13,6,0)<=2)) & - cycle + cycle do plusd7 = min(and7,16), max(and7 - 14,0)& - , -1 - ansats(13,7,1) = plusd7 - ansats(13,7,0) = and7 - plusd7 + , -1 + ansats(13,7,1) = plusd7 + ansats(13,7,0) = and7 - plusd7 ! 13l call sluggo (13, 8, varmax, varupp, varned& , ansats, org, lock(13,8), low, start(13& - ,8), stopp(13,8)) - do and8 = start(13,8), stopp(13,8), -1 - antel(13,8) = and8 + antel(13,7) + ,8), stopp(13,8)) + do and8 = start(13,8), stopp(13,8), -1 + antel(13,8) = and8 + antel(13,7) if (.not.(antel(13,8)<=antal .and. ansats(& 13,7,1)<=2 .and. ansats(13,7,0)<=2)) & - cycle + cycle do plusd8 = min(and8,18), max(and8 - 16,0)& - , -1 - ansats(13,8,1) = plusd8 - ansats(13,8,0) = and8 - plusd8 + , -1 + ansats(13,8,1) = plusd8 + ansats(13,8,0) = and8 - plusd8 ! 13m call sluggo (13, 9, varmax, varupp, varned& , ansats, org, lock(13,9), low, start(13& - ,9), stopp(13,9)) - do and9 = start(13,9), stopp(13,9), -1 - antel(13,9) = and9 + antel(13,8) + ,9), stopp(13,9)) + do and9 = start(13,9), stopp(13,9), -1 + antel(13,9) = and9 + antel(13,8) if (.not.(antel(13,9)<=antal .and. ansats(& 13,8,1)<=2 .and. ansats(13,8,0)<=2)) & - cycle + cycle do plusd9 = min(and9,20), max(and9 - 18,0)& - , -1 - ansats(13,9,1) = plusd9 - ansats(13,9,0) = and9 - plusd9 + , -1 + ansats(13,9,1) = plusd9 + ansats(13,9,0) = and9 - plusd9 ! 13n call sluggo (13, 10, varmax, varupp, varned& , ansats, org, lock(13,10), low, start(& - 13,10), stopp(13,10)) - do anda = start(13,10), stopp(13,10), -1 - antel(13,10) = anda + antel(13,9) + 13,10), stopp(13,10)) + do anda = start(13,10), stopp(13,10), -1 + antel(13,10) = anda + antel(13,9) if (.not.(antel(13,10)<=antal .and. ansats(& 13,9,1)<=2 .and. ansats(13,9,0)<=2& - .and. antel(13,10)>=lim(13))) cycle + .and. antel(13,10)>=lim(13))) cycle do plusda = min(anda,22), max(anda - 20,0)& - , -1 - ansats(13,10,1) = plusda - ansats(13,10,0) = anda - plusda + , -1 + ansats(13,10,1) = plusda + ansats(13,10,0) = anda - plusda ! 14s call sluggo (14, 0, varmax, varupp, varned& , ansats, org, lock(14,0), low, start(14& - ,0), stopp(14,0)) - do ane0 = start(14,0), stopp(14,0), -1 - antel(14,0) = ane0 + antel(13,10) + ,0), stopp(14,0)) + do ane0 = start(14,0), stopp(14,0), -1 + antel(14,0) = ane0 + antel(13,10) if (.not.(antel(14,0)<=antal .and. ansats(& 13,10,1)<=2 .and. ansats(13,10,0)<=2)) & - cycle - ansats(14,0,0) = ane0 + cycle + ansats(14,0,0) = ane0 ! 14p call sluggo (14, 1, varmax, varupp, varned& , ansats, org, lock(14,1), low, start(14& - ,1), stopp(14,1)) - do ane1 = start(14,1), stopp(14,1), -1 - antel(14,1) = ane1 + antel(14,0) - if (antel(14,1) > antal) cycle + ,1), stopp(14,1)) + do ane1 = start(14,1), stopp(14,1), -1 + antel(14,1) = ane1 + antel(14,0) + if (antel(14,1) > antal) cycle do pluse1 = min(ane1,4), max(ane1 - 2,0), & - -1 - ansats(14,1,1) = pluse1 - ansats(14,1,0) = ane1 - pluse1 + -1 + ansats(14,1,1) = pluse1 + ansats(14,1,0) = ane1 - pluse1 ! 14d call sluggo (14, 2, varmax, varupp, varned& , ansats, org, lock(14,2), low, start(14& - ,2), stopp(14,2)) - do ane2 = start(14,2), stopp(14,2), -1 - antel(14,2) = ane2 + antel(14,1) - if (antel(14,2) > antal) cycle + ,2), stopp(14,2)) + do ane2 = start(14,2), stopp(14,2), -1 + antel(14,2) = ane2 + antel(14,1) + if (antel(14,2) > antal) cycle do pluse2 = min(ane2,6), max(ane2 - 4,0), & - -1 - ansats(14,2,1) = pluse2 - ansats(14,2,0) = ane2 - pluse2 + -1 + ansats(14,2,1) = pluse2 + ansats(14,2,0) = ane2 - pluse2 ! 14f call sluggo (14, 3, varmax, varupp, varned& , ansats, org, lock(14,3), low, start(14& - ,3), stopp(14,3)) - do ane3 = start(14,3), stopp(14,3), -1 - antel(14,3) = ane3 + antel(14,2) - if (antel(14,3) > antal) cycle + ,3), stopp(14,3)) + do ane3 = start(14,3), stopp(14,3), -1 + antel(14,3) = ane3 + antel(14,2) + if (antel(14,3) > antal) cycle do pluse3 = min(ane3,8), max(ane3 - 6,0), & - -1 - ansats(14,3,1) = pluse3 - ansats(14,3,0) = ane3 - pluse3 + -1 + ansats(14,3,1) = pluse3 + ansats(14,3,0) = ane3 - pluse3 ! 14g call sluggo (14, 4, varmax, varupp, varned& , ansats, org, lock(14,4), low, start(14& - ,4), stopp(14,4)) - do ane4 = start(14,4), stopp(14,4), -1 - antel(14,4) = ane4 + antel(14,3) - if (antel(14,4) > antal) cycle + ,4), stopp(14,4)) + do ane4 = start(14,4), stopp(14,4), -1 + antel(14,4) = ane4 + antel(14,3) + if (antel(14,4) > antal) cycle do pluse4 = min(ane4,10), max(ane4 - 8,0), & - -1 - ansats(14,4,1) = pluse4 - ansats(14,4,0) = ane4 - pluse4 + -1 + ansats(14,4,1) = pluse4 + ansats(14,4,0) = ane4 - pluse4 ! 14h call sluggo (14, 5, varmax, varupp, varned& , ansats, org, lock(14,5), low, start(14& - ,5), stopp(14,5)) - do ane5 = start(14,5), stopp(14,5), -1 - antel(14,5) = ane5 + antel(14,4) + ,5), stopp(14,5)) + do ane5 = start(14,5), stopp(14,5), -1 + antel(14,5) = ane5 + antel(14,4) if (antel(14,5)>antal .or. ansats(14,4,1)>2& - ) cycle + ) cycle do pluse5 = min(ane5,12), max(ane5 - 10,0)& - , -1 - ansats(14,5,1) = pluse5 - ansats(14,5,0) = ane5 - pluse5 + , -1 + ansats(14,5,1) = pluse5 + ansats(14,5,0) = ane5 - pluse5 ! 14i call sluggo (14, 6, varmax, varupp, varned& , ansats, org, lock(14,6), low, start(14& - ,6), stopp(14,6)) - do ane6 = start(14,6), stopp(14,6), -1 - antel(14,6) = ane6 + antel(14,5) + ,6), stopp(14,6)) + do ane6 = start(14,6), stopp(14,6), -1 + antel(14,6) = ane6 + antel(14,5) if (.not.(antel(14,6)<=antal .and. ansats(& 14,5,1)<=2 .and. ansats(14,5,0)<=2)) & - cycle + cycle do pluse6 = min(ane6,14), max(ane6 - 12,0)& - , -1 - ansats(14,6,1) = pluse6 - ansats(14,6,0) = ane6 - pluse6 + , -1 + ansats(14,6,1) = pluse6 + ansats(14,6,0) = ane6 - pluse6 ! 14k call sluggo (14, 7, varmax, varupp, varned& , ansats, org, lock(14,7), low, start(14& - ,7), stopp(14,7)) - do ane7 = start(14,7), stopp(14,7), -1 - antel(14,7) = ane7 + antel(14,6) + ,7), stopp(14,7)) + do ane7 = start(14,7), stopp(14,7), -1 + antel(14,7) = ane7 + antel(14,6) if (.not.(antel(14,7)<=antal .and. ansats(& 14,6,1)<=2 .and. ansats(14,6,0)<=2)) & - cycle + cycle do pluse7 = min(ane7,16), max(ane7 - 14,0)& - , -1 - ansats(14,7,1) = pluse7 - ansats(14,7,0) = ane7 - pluse7 + , -1 + ansats(14,7,1) = pluse7 + ansats(14,7,0) = ane7 - pluse7 ! 14l call sluggo (14, 8, varmax, varupp, varned& , ansats, org, lock(14,8), low, start(14& - ,8), stopp(14,8)) - do ane8 = start(14,8), stopp(14,8), -1 - antel(14,8) = ane8 + antel(14,7) + ,8), stopp(14,8)) + do ane8 = start(14,8), stopp(14,8), -1 + antel(14,8) = ane8 + antel(14,7) if (.not.(antel(14,8)<=antal .and. ansats(& 14,7,1)<=2 .and. ansats(14,7,0)<=2)) & - cycle + cycle do pluse8 = min(ane8,18), max(ane8 - 16,0)& - , -1 - ansats(14,8,1) = pluse8 - ansats(14,8,0) = ane8 - pluse8 + , -1 + ansats(14,8,1) = pluse8 + ansats(14,8,0) = ane8 - pluse8 ! 14m call sluggo (14, 9, varmax, varupp, varned& , ansats, org, lock(14,9), low, start(14& - ,9), stopp(14,9)) - do ane9 = start(14,9), stopp(14,9), -1 - antel(14,9) = ane9 + antel(14,8) + ,9), stopp(14,9)) + do ane9 = start(14,9), stopp(14,9), -1 + antel(14,9) = ane9 + antel(14,8) if (.not.(antel(14,9)<=antal .and. ansats(& 14,8,1)<=2 .and. ansats(14,8,0)<=2)) & - cycle + cycle do pluse9 = min(ane9,20), max(ane9 - 18,0)& - , -1 - ansats(14,9,1) = pluse9 - ansats(14,9,0) = ane9 - pluse9 + , -1 + ansats(14,9,1) = pluse9 + ansats(14,9,0) = ane9 - pluse9 ! 14n call sluggo (14, 10, varmax, varupp, varned& , ansats, org, lock(14,10), low, start(& - 14,10), stopp(14,10)) - do anea = start(14,10), stopp(14,10), -1 - antel(14,10) = anea + antel(14,9) + 14,10), stopp(14,10)) + do anea = start(14,10), stopp(14,10), -1 + antel(14,10) = anea + antel(14,9) if (.not.(antel(14,10)<=antal .and. ansats(& 14,9,1)<=2 .and. ansats(14,9,0)<=2& - .and. antel(14,10)>=lim(14))) cycle + .and. antel(14,10)>=lim(14))) cycle do plusea = min(anea,22), max(anea - 20,0)& - , -1 - ansats(14,10,1) = plusea - ansats(14,10,0) = anea - plusea + , -1 + ansats(14,10,1) = plusea + ansats(14,10,0) = anea - plusea ! 15s call sluggo (15, 0, varmax, varupp, varned& , ansats, org, lock(15,0), low, start(15& - ,0), stopp(15,0)) - do anf0 = start(15,0), stopp(15,0), -1 - antel(15,0) = anf0 + antel(14,10) + ,0), stopp(15,0)) + do anf0 = start(15,0), stopp(15,0), -1 + antel(15,0) = anf0 + antel(14,10) if (.not.(antel(15,0)<=antal .and. ansats(& 14,10,1)<=2 .and. ansats(14,10,0)<=2)) & - cycle - ansats(15,0,0) = anf0 + cycle + ansats(15,0,0) = anf0 ! 15p call sluggo (15, 1, varmax, varupp, varned& , ansats, org, lock(15,1), low, start(15& - ,1), stopp(15,1)) - do anf1 = start(15,1), stopp(15,1), -1 - antel(15,1) = anf1 + antel(15,0) - if (antel(15,1) > antal) cycle + ,1), stopp(15,1)) + do anf1 = start(15,1), stopp(15,1), -1 + antel(15,1) = anf1 + antel(15,0) + if (antel(15,1) > antal) cycle do plusf1 = min(anf1,4), max(anf1 - 2,0), & - -1 - ansats(15,1,1) = plusf1 - ansats(15,1,0) = anf1 - plusf1 + -1 + ansats(15,1,1) = plusf1 + ansats(15,1,0) = anf1 - plusf1 ! 15d call sluggo (15, 2, varmax, varupp, varned& , ansats, org, lock(15,2), low, start(15& - ,2), stopp(15,2)) - do anf2 = start(15,2), stopp(15,2), -1 - antel(15,2) = anf2 + antel(15,1) - if (antel(15,2) > antal) cycle + ,2), stopp(15,2)) + do anf2 = start(15,2), stopp(15,2), -1 + antel(15,2) = anf2 + antel(15,1) + if (antel(15,2) > antal) cycle do plusf2 = min(anf2,6), max(anf2 - 4,0), & - -1 - ansats(15,2,1) = plusf2 - ansats(15,2,0) = anf2 - plusf2 + -1 + ansats(15,2,1) = plusf2 + ansats(15,2,0) = anf2 - plusf2 ! 15f call sluggo (15, 3, varmax, varupp, varned& , ansats, org, lock(15,3), low, start(15& - ,3), stopp(15,3)) - do anf3 = start(15,3), stopp(15,3), -1 - antel(15,3) = anf3 + antel(15,2) - if (antel(15,3) > antal) cycle + ,3), stopp(15,3)) + do anf3 = start(15,3), stopp(15,3), -1 + antel(15,3) = anf3 + antel(15,2) + if (antel(15,3) > antal) cycle do plusf3 = min(anf3,8), max(anf3 - 6,0), & - -1 - ansats(15,3,1) = plusf3 - ansats(15,3,0) = anf3 - plusf3 + -1 + ansats(15,3,1) = plusf3 + ansats(15,3,0) = anf3 - plusf3 ! 15g call sluggo (15, 4, varmax, varupp, varned& , ansats, org, lock(15,4), low, start(15& - ,4), stopp(15,4)) - do anf4 = start(15,4), stopp(15,4), -1 - antel(15,4) = anf4 + antel(15,3) - if (antel(15,4) > antal) cycle + ,4), stopp(15,4)) + do anf4 = start(15,4), stopp(15,4), -1 + antel(15,4) = anf4 + antel(15,3) + if (antel(15,4) > antal) cycle do plusf4 = min(anf4,10), max(anf4 - 8,0), & - -1 - ansats(15,4,1) = plusf4 - ansats(15,4,0) = anf4 - plusf4 + -1 + ansats(15,4,1) = plusf4 + ansats(15,4,0) = anf4 - plusf4 ! 15h call sluggo (15, 5, varmax, varupp, varned& , ansats, org, lock(15,5), low, start(15& - ,5), stopp(15,5)) - do anf5 = start(15,5), stopp(15,5), -1 - antel(15,5) = anf5 + antel(15,4) + ,5), stopp(15,5)) + do anf5 = start(15,5), stopp(15,5), -1 + antel(15,5) = anf5 + antel(15,4) if (antel(15,5)>antal .or. ansats(15,4,1)>2& - ) cycle + ) cycle do plusf5 = min(anf5,12), max(anf5 - 10,0)& - , -1 - ansats(15,5,1) = plusf5 - ansats(15,5,0) = anf5 - plusf5 + , -1 + ansats(15,5,1) = plusf5 + ansats(15,5,0) = anf5 - plusf5 ! 15i call sluggo (15, 6, varmax, varupp, varned& , ansats, org, lock(15,6), low, start(15& - ,6), stopp(15,6)) - do anf6 = start(15,6), stopp(15,6), -1 - antel(15,6) = anf6 + antel(15,5) + ,6), stopp(15,6)) + do anf6 = start(15,6), stopp(15,6), -1 + antel(15,6) = anf6 + antel(15,5) if (.not.(antel(15,6)<=antal .and. ansats(& 15,5,1)<=2 .and. ansats(15,5,0)<=2)) & - cycle + cycle do plusf6 = min(anf6,14), max(anf6 - 12,0)& - , -1 - ansats(15,6,1) = plusf6 - ansats(15,6,0) = anf6 - plusf6 + , -1 + ansats(15,6,1) = plusf6 + ansats(15,6,0) = anf6 - plusf6 ! 15k call sluggo (15, 7, varmax, varupp, varned& , ansats, org, lock(15,7), low, start(15& - ,7), stopp(15,7)) - do anf7 = start(15,7), stopp(15,7), -1 - antel(15,7) = anf7 + antel(15,6) + ,7), stopp(15,7)) + do anf7 = start(15,7), stopp(15,7), -1 + antel(15,7) = anf7 + antel(15,6) if (.not.(antel(15,7)<=antal .and. ansats(& 15,6,1)<=2 .and. ansats(15,6,0)<=2)) & - cycle + cycle do plusf7 = min(anf7,16), max(anf7 - 14,0)& - , -1 - ansats(15,7,1) = plusf7 - ansats(15,7,0) = anf7 - plusf7 + , -1 + ansats(15,7,1) = plusf7 + ansats(15,7,0) = anf7 - plusf7 ! 15l call sluggo (15, 8, varmax, varupp, varned& , ansats, org, lock(15,8), low, start(15& - ,8), stopp(15,8)) - do anf8 = start(15,8), stopp(15,8), -1 - antel(15,8) = anf8 + antel(15,7) + ,8), stopp(15,8)) + do anf8 = start(15,8), stopp(15,8), -1 + antel(15,8) = anf8 + antel(15,7) if (.not.(antel(15,8)<=antal .and. ansats(& 15,7,1)<=2 .and. ansats(15,7,0)<=2)) & - cycle + cycle do plusf8 = min(anf8,18), max(anf8 - 16,0)& - , -1 - ansats(15,8,1) = plusf8 - ansats(15,8,0) = anf8 - plusf8 + , -1 + ansats(15,8,1) = plusf8 + ansats(15,8,0) = anf8 - plusf8 ! 15m call sluggo (15, 9, varmax, varupp, varned& , ansats, org, lock(15,9), low, start(15& - ,9), stopp(15,9)) - do anf9 = start(15,9), stopp(15,9), -1 - antel(15,9) = anf9 + antel(15,8) + ,9), stopp(15,9)) + do anf9 = start(15,9), stopp(15,9), -1 + antel(15,9) = anf9 + antel(15,8) if (.not.(antel(15,9)<=antal .and. ansats(& 15,8,1)<=2 .and. ansats(15,8,0)<=2)) & - cycle + cycle do plusf9 = min(anf9,20), max(anf9 - 18,0)& - , -1 - ansats(15,9,1) = plusf9 - ansats(15,9,0) = anf9 - plusf9 + , -1 + ansats(15,9,1) = plusf9 + ansats(15,9,0) = anf9 - plusf9 ! 15n call sluggo (15, 10, varmax, varupp, varned& , ansats, org, lock(15,10), low, start(& - 15,10), stopp(15,10)) - do anfa = start(15,10), stopp(15,10), -1 - antel(15,10) = anfa + antel(15,9) + 15,10), stopp(15,10)) + do anfa = start(15,10), stopp(15,10), -1 + antel(15,10) = anfa + antel(15,9) if (.not.(antel(15,10)==antal .and. ansats(& 15,9,1)<=2 .and. ansats(15,9,0)<=2)) & - cycle + cycle do plusfa = min(anfa,22), max(anfa - 20,0)& - , -1 - ansats(15,10,1) = plusfa - ansats(15,10,0) = anfa - plusfa + , -1 + ansats(15,10,1) = plusfa + ansats(15,10,0) = anfa - plusfa if (ansats(15,10,1)>2 .or. ansats(15,10,0)>& - 2) cycle - par = 0 - elar = 0 - do i = 1, nmax - do j = 0, min(10,i - 1) - elar = elar + (ansats(i,j,0)+ansats(i,j,1)) + 2) cycle + par = 0 + elar = 0 + do i = 1, nmax + do j = 0, min(10,i - 1) + elar = elar + (ansats(i,j,0)+ansats(i,j,1)) par = mod(par + j*(ansats(i,j,0)+ansats(i,j& - ,1)),2) - end do - end do - if (par /= par0) cycle - if (elar /= antal) write (*, *) 'FEL' - cf = cf + 1 - do i = 1, 15 + ,1)),2) + end do + end do + if (par /= par0) cycle + if (elar /= antal) write (*, *) 'FEL' + cf = cf + 1 + do i = 1, 15 write (fil, 5000) (ansats(i,j,0),j=0,min(10& - ,i - 1)) + ,i - 1)) write (fil, 5000) (ansats(i,j,1),j=0,min(10& - ,i - 1)) - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - 5000 format(11i2) - return - end subroutine blandb + ,i - 1)) + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + 5000 format(11i2) + return + end subroutine blandb diff --git a/src/appl/jjgen90/blandb_I.f90 b/src/appl/jjgen90/blandb_I.f90 index db96730c5..151925caf 100644 --- a/src/appl/jjgen90/blandb_I.f90 +++ b/src/appl/jjgen90/blandb_I.f90 @@ -1,19 +1,19 @@ - MODULE blandb_I + MODULE blandb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blandb (ORG, NMAX, VARMAX, LOCK, FIL, LOW, LIM, POSN, POSL& - , MINJ, MAXJ) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - integer, INTENT(IN) :: NMAX - integer :: VARMAX - logical, DIMENSION(15,0:10) :: LOCK - integer, INTENT(IN) :: FIL - integer, DIMENSION(15,0:10) :: LOW - integer, DIMENSION(15), INTENT(IN) :: LIM - integer, DIMENSION(110) :: POSN - integer, DIMENSION(110) :: POSL - integer :: MINJ - integer :: MAXJ - END SUBROUTINE - END INTERFACE - END MODULE + , MINJ, MAXJ) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + integer, INTENT(IN) :: NMAX + integer :: VARMAX + logical, DIMENSION(15,0:10) :: LOCK + integer, INTENT(IN) :: FIL + integer, DIMENSION(15,0:10) :: LOW + integer, DIMENSION(15), INTENT(IN) :: LIM + integer, DIMENSION(110) :: POSN + integer, DIMENSION(110) :: POSL + integer :: MINJ + integer :: MAXJ + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/blandc.f90 b/src/appl/jjgen90/blandc.f90 index 436c06e42..7d171447a 100644 --- a/src/appl/jjgen90/blandc.f90 +++ b/src/appl/jjgen90/blandc.f90 @@ -1,281 +1,281 @@ ! last edited August 1, 1996 subroutine blandc(varmax, cfmax, lock, med, minj, maxj, nmax, posn, posl& - , lim) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + , lim) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use blandb_I - use mergeb_I - use gen_I + use blandb_I + use mergeb_I + use gen_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer , intent(in) :: cfmax - integer :: minj - integer :: maxj - integer :: nmax - integer :: posn(110) - integer :: posl(110) - integer :: lim(15) - logical :: lock(15,0:10) - logical , intent(in) :: med(15,0:10) + integer :: varmax + integer , intent(in) :: cfmax + integer :: minj + integer :: maxj + integer :: nmax + integer :: posn(110) + integer :: posl(110) + integer :: lim(15) + logical :: lock(15,0:10) + logical , intent(in) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: cf - integer , dimension(15,0:10) :: org - integer :: i, j, n, k, l, l1, antal, tal, antalc - integer , dimension(15,0:10) :: low - integer :: tot - integer , dimension(15000,15,0:10) :: lista - integer , dimension(15,0:10,0:1) :: ansats - integer :: par, start, stopp, skal, duplet, kvar - logical :: finns - logical, dimension(15000) :: lik - character :: rad*500 - character, dimension(0:10) :: orb + integer :: cf + integer , dimension(15,0:10) :: org + integer :: i, j, n, k, l, l1, antal, tal, antalc + integer , dimension(15,0:10) :: low + integer :: tot + integer , dimension(15000,15,0:10) :: lista + integer , dimension(15,0:10,0:1) :: ansats + integer :: par, start, stopp, skal, duplet, kvar + logical :: finns + logical, dimension(15000) :: lik + character :: rad*500 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - cf = 0 - antalc = 0 - tot = 0 - skal = 20 - finns = .FALSE. - do i = 1, 15 - org(i,:min(10,i-1)) = 0 - low(i,:min(10,i-1)) = 0 - end do - open(unit=7, status='scratch', position='asis') - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) - do i = 1, 500 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (.not.(med(i,j) .or. .not.lock(i,j))) cycle - start = start + 5 - stopp = stopp + 5 - rad(start:start) = char(ichar('0') + i) - rad(start+1:start+1) = orb(j) - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - rad(start:start) = char(ichar('0') + i) - rad(start+1:start+1) = orb(j) - end do - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - 2 continue - read (fil_2, 1000, end=200) rad - read (fil_2, 1000, end=200) - read (fil_2, 1000, end=200) - tot = tot + 1 - do i = 1, 15 - lista(tot,i,:min(10,i-1)) = 0 - end do - do i = 1, skal - n = 9*(i - 1) + 3 - l = n + 1 - tal = ichar(rad(n:n)) - ichar('0') - if (tal>=1 .and. tal<=15) then - l1 = -1 - do j = 0, tal - 1 - if (orb(j) /= rad(l:l)) cycle - l1 = j - end do - if (l1 == (-1)) exit - else - exit - endif - antal = ichar(rad(l+3:l+3)) - ichar('0') - if (antal>=0 .and. antal<=9) then - antal = antal*10 - else - antal = 0 - endif - antal = antal + ichar(rad(l+4:l+4)) - ichar('0') - lista(tot,tal,l1) = lista(tot,tal,l1) + antal - end do - go to 2 - 200 continue - if (tot == 0) then - write (*, 1005) 'Nothing in inputfile!' - stop - endif - if (tot < 10) then - write (*, 2001) 'Number of csf:s in inputfile = ', tot - else if (tot < 100) then - write (*, 2002) 'Number of csf:s in inputfile = ', tot - else if (tot < 1000) then - write (*, 2003) 'Number of csf:s in inputfile = ', tot - else if (tot < 10000) then - write (*, 2004) 'Number of csf:s in inputfile = ', tot - else - write (*, 2005) 'Number of csf:s in inputfile = ', tot - endif - duplet = 0 - lik(:tot) = .FALSE. - if (tot >= 2) then - do i = 1, tot - 1 - if (lik(i)) cycle - l302: do j = i + 1, tot - if (lik(j)) cycle l302 - do k = 1, nmax - do l = 0, min(10,k - 1) - if (lista(i,k,l) == lista(j,k,l)) cycle - cycle l302 - end do - end do - lik(j) = .TRUE. - end do l302 - end do - endif - duplet = duplet + count(lik(:tot)) - if (duplet < 10) then - write (*, 2001) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 100) then - write (*, 2002) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 1000) then - write (*, 2003) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 10000) then - write (*, 2004) 'Number of duplicat csf:s in file = ', duplet - else - write (*, 2005) 'Number of duplicat csf:s in file = ', duplet - endif - kvar = tot - duplet - write (*, *) - do i = 1, tot - if (.not.lik(i)) then - if (kvar > 1) then - if (kvar < 10) then - write (*, 1001) kvar, ' csf:s still to be expanded.' - else if (kvar < 100) then - write (*, 1002) kvar, ' csf:s still to be expanded.' - else if (kvar < 1000) then - write (*, 1003) kvar, ' csf:s still to be expanded.' - else if (kvar < 10000) then - write (*, 1004) kvar, ' csf:s still to be expanded.' - else - write (*, 1006) kvar, ' csf:s still to be expanded.' - endif - else - write (*, 1005) 'The last csf is still to be expanded.' - endif - kvar = kvar - 1 - par = 0 - do k = 1, nmax - org(k,:min(k-1,10)) = lista(i,k,:min(k-1,10)) - end do - if (finns) then - open(unit=21, status='scratch', position='asis') + 'n'/ + cf = 0 + antalc = 0 + tot = 0 + skal = 20 + finns = .FALSE. + do i = 1, 15 + org(i,:min(10,i-1)) = 0 + low(i,:min(10,i-1)) = 0 + end do + open(unit=7, status='scratch', position='asis') + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) + do i = 1, 500 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (.not.(med(i,j) .or. .not.lock(i,j))) cycle + start = start + 5 + stopp = stopp + 5 + rad(start:start) = char(ichar('0') + i) + rad(start+1:start+1) = orb(j) + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + rad(start:start) = char(ichar('0') + i) + rad(start+1:start+1) = orb(j) + end do + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + 2 continue + read (fil_2, 1000, end=200) rad + read (fil_2, 1000, end=200) + read (fil_2, 1000, end=200) + tot = tot + 1 + do i = 1, 15 + lista(tot,i,:min(10,i-1)) = 0 + end do + do i = 1, skal + n = 9*(i - 1) + 3 + l = n + 1 + tal = ichar(rad(n:n)) - ichar('0') + if (tal>=1 .and. tal<=15) then + l1 = -1 + do j = 0, tal - 1 + if (orb(j) /= rad(l:l)) cycle + l1 = j + end do + if (l1 == (-1)) exit + else + exit + endif + antal = ichar(rad(l+3:l+3)) - ichar('0') + if (antal>=0 .and. antal<=9) then + antal = antal*10 + else + antal = 0 + endif + antal = antal + ichar(rad(l+4:l+4)) - ichar('0') + lista(tot,tal,l1) = lista(tot,tal,l1) + antal + end do + go to 2 + 200 continue + if (tot == 0) then + write (*, 1005) 'Nothing in inputfile!' + stop + endif + if (tot < 10) then + write (*, 2001) 'Number of csf:s in inputfile = ', tot + else if (tot < 100) then + write (*, 2002) 'Number of csf:s in inputfile = ', tot + else if (tot < 1000) then + write (*, 2003) 'Number of csf:s in inputfile = ', tot + else if (tot < 10000) then + write (*, 2004) 'Number of csf:s in inputfile = ', tot + else + write (*, 2005) 'Number of csf:s in inputfile = ', tot + endif + duplet = 0 + lik(:tot) = .FALSE. + if (tot >= 2) then + do i = 1, tot - 1 + if (lik(i)) cycle + l302: do j = i + 1, tot + if (lik(j)) cycle l302 + do k = 1, nmax + do l = 0, min(10,k - 1) + if (lista(i,k,l) == lista(j,k,l)) cycle + cycle l302 + end do + end do + lik(j) = .TRUE. + end do l302 + end do + endif + duplet = duplet + count(lik(:tot)) + if (duplet < 10) then + write (*, 2001) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 100) then + write (*, 2002) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 1000) then + write (*, 2003) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 10000) then + write (*, 2004) 'Number of duplicat csf:s in file = ', duplet + else + write (*, 2005) 'Number of duplicat csf:s in file = ', duplet + endif + kvar = tot - duplet + write (*, *) + do i = 1, tot + if (.not.lik(i)) then + if (kvar > 1) then + if (kvar < 10) then + write (*, 1001) kvar, ' csf:s still to be expanded.' + else if (kvar < 100) then + write (*, 1002) kvar, ' csf:s still to be expanded.' + else if (kvar < 1000) then + write (*, 1003) kvar, ' csf:s still to be expanded.' + else if (kvar < 10000) then + write (*, 1004) kvar, ' csf:s still to be expanded.' + else + write (*, 1006) kvar, ' csf:s still to be expanded.' + endif + else + write (*, 1005) 'The last csf is still to be expanded.' + endif + kvar = kvar - 1 + par = 0 + do k = 1, nmax + org(k,:min(k-1,10)) = lista(i,k,:min(k-1,10)) + end do + if (finns) then + open(unit=21, status='scratch', position='asis') call blandb (org, nmax, varmax, lock, 21, low, lim, posn, posl, & - minj, maxj) - rewind (21) - call mergeb (antalc) - if (antalc < 10) then - write (*, 2001) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 100) then - write (*, 2002) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 1000) then - write (*, 2003) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 10000) then - write (*, 2004) 'Number of uncoupled csf:s = ', antalc - else - write (*, 2005) 'Number of uncoupled csf:s = ', antalc - endif - else - open(unit=20, status='scratch', position='asis') + minj, maxj) + rewind (21) + call mergeb (antalc) + if (antalc < 10) then + write (*, 2001) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 100) then + write (*, 2002) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 1000) then + write (*, 2003) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 10000) then + write (*, 2004) 'Number of uncoupled csf:s = ', antalc + else + write (*, 2005) 'Number of uncoupled csf:s = ', antalc + endif + else + open(unit=20, status='scratch', position='asis') call blandb (org, nmax, varmax, lock, 20, low, lim, posn, posl, & - minj, maxj) - rewind (20) - finns = .TRUE. - antalc = 0 - write (*, 1005) 'The first configuration has been expanded.' - endif - if (antalc >= cfmax) then - write (*, 1005) 'Maximum number of uncoupled csf:s exceeded' - exit - endif - endif - end do - write (*, *) - write (*, 1005) 'Preparing the couplings of the csf:s.' - - if (nmax < 15) then - do i = nmax + 1, 15 - ansats(i,:min(10,i-1),0) = 0 - ansats(i,:min(10,i-1),1) = 0 - end do - endif - cf = 0 - 490 continue - do i = 1, 15 - read (20, 5000, end=492) (ansats(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=492) (ansats(i,j,1),j=0,min(10,i - 1)) - end do - par = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, min(j,1) - par = mod(par + j*ansats(i,j,k),2) - end do - end do - end do - call gen (ansats, posn, posl, skal, cf, .TRUE., minj, maxj, par) - go to 490 - 492 continue - rewind (fil_1) - if (cf == 0) then - write (*, 1005) 'No configuration state has been generated.' - else if (cf == 1) then - write (*, 1005) 'One configuration state has been generated.' - else if (cf < 10) then - write (*, 1001) cf, ' configuration states have been generated.' - else if (cf < 100) then - write (*, 1002) cf, ' configuration states have been generated.' - else if (cf < 1000) then - write (*, 1003) cf, ' configuration states have been generated.' - else if (cf < 10000) then - write (*, 1004) cf, ' configuration states have been generated.' - else if (cf < 100000) then - write (*, 1006) cf, ' configuration states have been generated.' - else - write (*, *) cf, ' configuration states have been generated.' - endif - 1000 format(a) - 1001 format(' ',i1,a) - 1002 format(' ',i2,a) - 1003 format(' ',i3,a) - 1004 format(' ',i4,a) - 1005 format(' ',a) - 1006 format(' ',i5,a) - 2001 format(' ',a,i1,'.') - 2002 format(' ',a,i2,'.') - 2003 format(' ',a,i3,'.') - 2004 format(' ',a,i4,'.') - 2005 format(' ',a,i5,'.') - - 5000 format(11i2) - return - end subroutine blandc + minj, maxj) + rewind (20) + finns = .TRUE. + antalc = 0 + write (*, 1005) 'The first configuration has been expanded.' + endif + if (antalc >= cfmax) then + write (*, 1005) 'Maximum number of uncoupled csf:s exceeded' + exit + endif + endif + end do + write (*, *) + write (*, 1005) 'Preparing the couplings of the csf:s.' + + if (nmax < 15) then + do i = nmax + 1, 15 + ansats(i,:min(10,i-1),0) = 0 + ansats(i,:min(10,i-1),1) = 0 + end do + endif + cf = 0 + 490 continue + do i = 1, 15 + read (20, 5000, end=492) (ansats(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=492) (ansats(i,j,1),j=0,min(10,i - 1)) + end do + par = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, min(j,1) + par = mod(par + j*ansats(i,j,k),2) + end do + end do + end do + call gen (ansats, posn, posl, skal, cf, .TRUE., minj, maxj, par) + go to 490 + 492 continue + rewind (fil_1) + if (cf == 0) then + write (*, 1005) 'No configuration state has been generated.' + else if (cf == 1) then + write (*, 1005) 'One configuration state has been generated.' + else if (cf < 10) then + write (*, 1001) cf, ' configuration states have been generated.' + else if (cf < 100) then + write (*, 1002) cf, ' configuration states have been generated.' + else if (cf < 1000) then + write (*, 1003) cf, ' configuration states have been generated.' + else if (cf < 10000) then + write (*, 1004) cf, ' configuration states have been generated.' + else if (cf < 100000) then + write (*, 1006) cf, ' configuration states have been generated.' + else + write (*, *) cf, ' configuration states have been generated.' + endif + 1000 format(a) + 1001 format(' ',i1,a) + 1002 format(' ',i2,a) + 1003 format(' ',i3,a) + 1004 format(' ',i4,a) + 1005 format(' ',a) + 1006 format(' ',i5,a) + 2001 format(' ',a,i1,'.') + 2002 format(' ',a,i2,'.') + 2003 format(' ',a,i3,'.') + 2004 format(' ',a,i4,'.') + 2005 format(' ',a,i5,'.') + + 5000 format(11i2) + return + end subroutine blandc diff --git a/src/appl/jjgen90/blandc_I.f90 b/src/appl/jjgen90/blandc_I.f90 index 403886c39..56162d21a 100644 --- a/src/appl/jjgen90/blandc_I.f90 +++ b/src/appl/jjgen90/blandc_I.f90 @@ -1,18 +1,18 @@ - MODULE blandc_I + MODULE blandc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blandc (VARMAX, CFMAX, LOCK, MED, MINJ, MAXJ, NMAX, POSN, POSL& - , LIM) - integer :: VARMAX - integer, INTENT(IN) :: CFMAX - logical, DIMENSION(15,0:10), INTENT(IN) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: MED - integer :: MINJ - integer :: MAXJ - integer, INTENT(IN) :: NMAX - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL - integer, DIMENSION(15) :: LIM - END SUBROUTINE - END INTERFACE - END MODULE + , LIM) + integer :: VARMAX + integer, INTENT(IN) :: CFMAX + logical, DIMENSION(15,0:10), INTENT(IN) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: MED + integer :: MINJ + integer :: MAXJ + integer, INTENT(IN) :: NMAX + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL + integer, DIMENSION(15) :: LIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/copy7t9.f90 b/src/appl/jjgen90/copy7t9.f90 index 6cdff8daf..f2aee2aec 100644 --- a/src/appl/jjgen90/copy7t9.f90 +++ b/src/appl/jjgen90/copy7t9.f90 @@ -1,27 +1,27 @@ - subroutine copy7t9 -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine copy7t9 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: utfil = 9 + integer, parameter :: fil_1 = 7 + integer, parameter :: utfil = 9 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - character :: rad11*1000 + character :: rad11*1000 !----------------------------------------------- - open(fil_1, file='clist.out', status='unknown', position='asis') - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - do while(.TRUE.) - read (utfil, 999, end=100) rad11 - write (fil_1, 999) trim(rad11) - end do - 100 continue - close(utfil, status='delete') - close(fil_1) - return - 999 format(a) - return - end subroutine copy7t9 + open(fil_1, file='clist.out', status='unknown', position='asis') + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + do while(.TRUE.) + read (utfil, 999, end=100) rad11 + write (fil_1, 999) trim(rad11) + end do + 100 continue + close(utfil, status='delete') + close(fil_1) + return + 999 format(a) + return + end subroutine copy7t9 diff --git a/src/appl/jjgen90/copy7t9_I.f90 b/src/appl/jjgen90/copy7t9_I.f90 index ec47a96e6..914d8f981 100644 --- a/src/appl/jjgen90/copy7t9_I.f90 +++ b/src/appl/jjgen90/copy7t9_I.f90 @@ -1,8 +1,8 @@ - MODULE copy7t9_I + MODULE copy7t9_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE copy7t9 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE copy7t9 !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/fivefirst.f90 b/src/appl/jjgen90/fivefirst.f90 index 0f208c8dc..30e977c5d 100644 --- a/src/appl/jjgen90/fivefirst.f90 +++ b/src/appl/jjgen90/fivefirst.f90 @@ -1,190 +1,190 @@ ! last edited Februar 20, 1996 - subroutine fivefirst(slut1, slut2, posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine fivefirst(slut1, slut2, posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(inout) :: slut1 - logical , intent(inout) :: slut2 - integer , intent(in) :: posn(110) - integer , intent(in) :: posl(110) + logical , intent(inout) :: slut1 + logical , intent(inout) :: slut2 + integer , intent(in) :: posn(110) + integer , intent(in) :: posl(110) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: k, i, j, n, l, pos, stopp - logical, dimension(15,0:10,0:1) :: med - character :: rad0*1000, rad1*1000, rad2*1000 - character, dimension(0:10) :: orb + integer :: k, i, j, n, l, pos, stopp + logical, dimension(15,0:10,0:1) :: med + character :: rad0*1000, rad1*1000, rad2*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - read (7, 999, end=100) - write (9, 999) 'Core subshells:' - read (7, 999, end=101) rad0 - stopp = 0 - do i = 0, 210 + 'n'/ + read (7, 999, end=100) + write (9, 999) 'Core subshells:' + read (7, 999, end=101) rad0 + stopp = 0 + do i = 0, 210 if (ichar(rad0(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad0(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad0(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'Peel subshells:' - read (7, 999, end=102) - read (7, 999, end=102) rad1 - read (7, 999, end=102) - if (.not.slut2) then - read (8, 999, end=90) - read (8, 999, end=90) - read (8, 999, end=90) - read (8, 999, end=90) rad2 - read (8, 999, end=90) - do i = 1, 15 - med(i,:min(10,i-1),0) = .FALSE. - med(i,:min(10,i-1),1) = .FALSE. - end do - do i = 1, 205 - pos = 5*i - n = ichar(rad1(pos-2:pos-2)) - ichar('0') - if (rad1(pos-3:pos-3) == '1') n = n + 10 - l = -1 - if (n>=1 .and. n<=15) then - do j = 0, min(10,n - 1) - if (rad1(pos-1:pos-1) /= orb(j)) cycle - l = j - end do - endif - if (l == (-1)) exit - if (rad1(pos:pos)=='-' .or. l==0) then - med(n,l,0) = .TRUE. - else - med(n,l,1) = .TRUE. - endif - end do - do i = 1, 205 - pos = 5*i - n = ichar(rad2(pos-2:pos-2)) - ichar('0') - if (rad2(pos-3:pos-3) == '1') n = n + 10 - l = -1 - if (n>=1 .and. n<=15) then - do j = 0, min(10,n - 1) - if (rad2(pos-1:pos-1) /= orb(j)) cycle - l = j - end do - endif - if (l == (-1)) exit - if (rad2(pos:pos)=='-' .or. l==0) then - med(n,l,0) = .TRUE. - else - med(n,l,1) = .TRUE. - endif - end do - pos = 3 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (med(i,j,0)) then - rad0(pos-2:pos+2) = ' ' - if (i < 10) then - rad0(pos:pos) = char(i + ichar('0')) - else - rad0(pos:pos) = char(i + ichar('0') - 10) - rad0(pos-1:pos-1) = '1' - endif - rad0(pos+1:pos+1) = orb(j) - if (j /= 0) rad0(pos+2:pos+2) = '-' - pos = pos + 5 - endif - if (.not.med(i,j,1)) cycle - rad0(pos-2:pos+2) = ' ' - if (i < 10) then - rad0(pos:pos) = char(i + ichar('0')) - else - rad0(pos:pos) = char(i + ichar('0') - 10) - rad0(pos-1:pos-1) = '1' - endif - rad0(pos+1:pos+1) = orb(j) - pos = pos + 5 - end do - write (9, 999) rad0(1:pos-3) - write (9, 999) 'CSF(s):' - return - endif - 90 continue - slut2 = .TRUE. - stopp = 0 - do i = 0, 210 + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad0(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'Peel subshells:' + read (7, 999, end=102) + read (7, 999, end=102) rad1 + read (7, 999, end=102) + if (.not.slut2) then + read (8, 999, end=90) + read (8, 999, end=90) + read (8, 999, end=90) + read (8, 999, end=90) rad2 + read (8, 999, end=90) + do i = 1, 15 + med(i,:min(10,i-1),0) = .FALSE. + med(i,:min(10,i-1),1) = .FALSE. + end do + do i = 1, 205 + pos = 5*i + n = ichar(rad1(pos-2:pos-2)) - ichar('0') + if (rad1(pos-3:pos-3) == '1') n = n + 10 + l = -1 + if (n>=1 .and. n<=15) then + do j = 0, min(10,n - 1) + if (rad1(pos-1:pos-1) /= orb(j)) cycle + l = j + end do + endif + if (l == (-1)) exit + if (rad1(pos:pos)=='-' .or. l==0) then + med(n,l,0) = .TRUE. + else + med(n,l,1) = .TRUE. + endif + end do + do i = 1, 205 + pos = 5*i + n = ichar(rad2(pos-2:pos-2)) - ichar('0') + if (rad2(pos-3:pos-3) == '1') n = n + 10 + l = -1 + if (n>=1 .and. n<=15) then + do j = 0, min(10,n - 1) + if (rad2(pos-1:pos-1) /= orb(j)) cycle + l = j + end do + endif + if (l == (-1)) exit + if (rad2(pos:pos)=='-' .or. l==0) then + med(n,l,0) = .TRUE. + else + med(n,l,1) = .TRUE. + endif + end do + pos = 3 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (med(i,j,0)) then + rad0(pos-2:pos+2) = ' ' + if (i < 10) then + rad0(pos:pos) = char(i + ichar('0')) + else + rad0(pos:pos) = char(i + ichar('0') - 10) + rad0(pos-1:pos-1) = '1' + endif + rad0(pos+1:pos+1) = orb(j) + if (j /= 0) rad0(pos+2:pos+2) = '-' + pos = pos + 5 + endif + if (.not.med(i,j,1)) cycle + rad0(pos-2:pos+2) = ' ' + if (i < 10) then + rad0(pos:pos) = char(i + ichar('0')) + else + rad0(pos:pos) = char(i + ichar('0') - 10) + rad0(pos-1:pos-1) = '1' + endif + rad0(pos+1:pos+1) = orb(j) + pos = pos + 5 + end do + write (9, 999) rad0(1:pos-3) + write (9, 999) 'CSF(s):' + return + endif + 90 continue + slut2 = .TRUE. + stopp = 0 + do i = 0, 210 if (ichar(rad1(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad1(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad1(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'CSF(s):' - return - 100 continue - slut1 = .TRUE. - write (9, 999) 'Core subshells:' - read (8, 999, end=200) rad0 - 101 continue - if (.not.slut1) then - slut1 = .TRUE. - read (8, 999, end=200) rad0 - endif - stopp = 0 - do i = 0, 210 + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad1(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'CSF(s):' + return + 100 continue + slut1 = .TRUE. + write (9, 999) 'Core subshells:' + read (8, 999, end=200) rad0 + 101 continue + if (.not.slut1) then + slut1 = .TRUE. + read (8, 999, end=200) rad0 + endif + stopp = 0 + do i = 0, 210 if (ichar(rad0(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad0(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad0(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'Peel subshells:' - 102 continue - if (.not.slut1) then - slut1 = .TRUE. - read (8, 999, end=200) - read (8, 999, end=200) rad2 - endif - stopp = 0 - do i = 0, 210 + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad0(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'Peel subshells:' + 102 continue + if (.not.slut1) then + slut1 = .TRUE. + read (8, 999, end=200) + read (8, 999, end=200) rad2 + endif + stopp = 0 + do i = 0, 210 if (ichar(rad2(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad2(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad2(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'CSF(s):' - return - 200 continue - slut2 = .TRUE. - return - 999 format(a) - return - end subroutine fivefirst + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad2(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'CSF(s):' + return + 200 continue + slut2 = .TRUE. + return + 999 format(a) + return + end subroutine fivefirst diff --git a/src/appl/jjgen90/fivefirst_I.f90 b/src/appl/jjgen90/fivefirst_I.f90 index 87753ac17..683b2e46b 100644 --- a/src/appl/jjgen90/fivefirst_I.f90 +++ b/src/appl/jjgen90/fivefirst_I.f90 @@ -1,12 +1,12 @@ - MODULE fivefirst_I + MODULE fivefirst_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE fivefirst (SLUT1, SLUT2, POSN, POSL) - logical, INTENT(INOUT) :: SLUT1 - logical, INTENT(INOUT) :: SLUT2 - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE fivefirst (SLUT1, SLUT2, POSN, POSL) + logical, INTENT(INOUT) :: SLUT1 + logical, INTENT(INOUT) :: SLUT2 + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/fivelines.f90 b/src/appl/jjgen90/fivelines.f90 index e2fc8d69f..194644904 100644 --- a/src/appl/jjgen90/fivelines.f90 +++ b/src/appl/jjgen90/fivelines.f90 @@ -1,121 +1,121 @@ ! last edited July 30, 1996 - subroutine fivelines(org, locked, closed, first, posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine fivelines(org, locked, closed, first, posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(in) :: first - integer , intent(inout) :: org(15,0:10) - integer , intent(in) :: posn(110) - integer , intent(in) :: posl(110) - logical , intent(in) :: locked(15,0:10) - logical , intent(in) :: closed(15,0:10) + logical , intent(in) :: first + integer , intent(inout) :: org(15,0:10) + integer , intent(in) :: posn(110) + integer , intent(in) :: posl(110) + logical , intent(in) :: locked(15,0:10) + logical , intent(in) :: closed(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: k, i, j, start, stopp - character :: rad*1000 - character, dimension(0:10) :: orb + integer :: k, i, j, start, stopp + character :: rad*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - if (.not.first) then + 'n'/ + if (.not.first) then ! open(unit=8,file='fil2.dat',status='unknown') - open(unit=8, status='scratch', position='asis') - write (8, 999) - write (8, 999) - write (8, 999) - else - open(unit=7, file='fil1.dat', status='unknown', position='asis') + open(unit=8, status='scratch', position='asis') + write (8, 999) + write (8, 999) + write (8, 999) + else + open(unit=7, file='fil1.dat', status='unknown', position='asis') ! open(unit=7,status='scratch') - write (7, 999) 'Core subshells:' - do i = 1, 1000 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (.not.closed(i,j)) cycle - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - org(i,j) = 0 - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - end do - if (stopp == 0) then - write (7, 999) - else - write (7, 999) rad(1:stopp) - endif - write (7, 999) 'Peel subshells:' - endif - do i = 1, 1000 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) + write (7, 999) 'Core subshells:' + do i = 1, 1000 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (.not.closed(i,j)) cycle + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + org(i,j) = 0 + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + end do + if (stopp == 0) then + write (7, 999) + else + write (7, 999) rad(1:stopp) + endif + write (7, 999) 'Peel subshells:' + endif + do i = 1, 1000 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) if (.not.(.not.(org(i,j)==0 .and. locked(i,j)) .and. .not.closed(i,j))& - ) cycle - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) + ) cycle + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) ! write(*,*) i,rad(1:100) - end do - if (first) then - if (stopp == 0) then - write (7, 999) - else - write (7, 999) rad(1:stopp) - endif - write (7, 999) 'CSF(s):' - else - if (stopp == 0) then - write (8, 999) - else - write (8, 999) rad(1:stopp) - endif - write (8, 999) 'CSF(s):' - endif - 999 format(a) - return - end subroutine fivelines + end do + if (first) then + if (stopp == 0) then + write (7, 999) + else + write (7, 999) rad(1:stopp) + endif + write (7, 999) 'CSF(s):' + else + if (stopp == 0) then + write (8, 999) + else + write (8, 999) rad(1:stopp) + endif + write (8, 999) 'CSF(s):' + endif + 999 format(a) + return + end subroutine fivelines diff --git a/src/appl/jjgen90/fivelines_I.f90 b/src/appl/jjgen90/fivelines_I.f90 index c4ffd0ea6..0248866d6 100644 --- a/src/appl/jjgen90/fivelines_I.f90 +++ b/src/appl/jjgen90/fivelines_I.f90 @@ -1,14 +1,14 @@ - MODULE fivelines_I + MODULE fivelines_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE fivelines (ORG, LOCKED, CLOSED, FIRST, POSN, POSL) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - logical, DIMENSION(15,0:10), INTENT(IN) :: LOCKED - logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - logical, INTENT(IN) :: FIRST - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE fivelines (ORG, LOCKED, CLOSED, FIRST, POSN, POSL) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + logical, DIMENSION(15,0:10), INTENT(IN) :: LOCKED + logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + logical, INTENT(IN) :: FIRST + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/gen.f90 b/src/appl/jjgen90/gen.f90 index 10e2f1e83..4a491d0e0 100644 --- a/src/appl/jjgen90/gen.f90 +++ b/src/appl/jjgen90/gen.f90 @@ -1,859 +1,859 @@ ! last edited July 31, 1996 - SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE kopp1_I - USE kopp2_I + USE kopp1_I + USE kopp2_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: SKAL - INTEGER , INTENT(INOUT) :: CF - INTEGER , INTENT(IN) :: MINJ - INTEGER , INTENT(IN) :: MAXJ - INTEGER :: PAR - LOGICAL , INTENT(IN) :: FIRST - INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) - INTEGER , INTENT(IN) :: POSN(110) - INTEGER , INTENT(IN) :: POSL(110) + INTEGER , INTENT(IN) :: SKAL + INTEGER , INTENT(INOUT) :: CF + INTEGER , INTENT(IN) :: MINJ + INTEGER , INTENT(IN) :: MAXJ + INTEGER :: PAR + LOGICAL , INTENT(IN) :: FIRST + INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) + INTEGER , INTENT(IN) :: POSN(110) + INTEGER , INTENT(IN) :: POSL(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: FIL_1 = 7 - INTEGER, PARAMETER :: FIL_2 = 8 + INTEGER, PARAMETER :: FIL_1 = 7 + INTEGER, PARAMETER :: FIL_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT - INTEGER , DIMENSION(0:10,0:1) :: ANTMAX - INTEGER :: POS, I, N, L, K - INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL + INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT + INTEGER , DIMENSION(0:10,0:1) :: ANTMAX + INTEGER :: POS, I, N, L, K + INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL INTEGER :: I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, I11, I12, I13, I14, & - I15, I16, I17, I18, I19, I20 - INTEGER , DIMENSION(20) :: PLUS, S + I15, I16, I17, I18, I19, I20 + INTEGER , DIMENSION(20) :: PLUS, S INTEGER :: RESJ, JK1, JK2, JK3, JK4, JK5, JK6, JK7, JK8, JK9, JK10, JK11& - , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL - INTEGER , DIMENSION(20) :: ANTKO - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR - INTEGER :: N1, N10 - CHARACTER :: RAD1*200, RAD2*200, RAD3*200 - CHARACTER, DIMENSION(0:10,0:1) :: L1*2 + , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL + INTEGER , DIMENSION(20) :: ANTKO + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR + INTEGER :: N1, N10 + CHARACTER :: RAD1*200, RAD2*200, RAD3*200 + CHARACTER, DIMENSION(0:10,0:1) :: L1*2 !----------------------------------------------- DATA (L1(I,0),I=0,10)/ 's ', 'p-', 'd-', 'f-', 'g-', 'h-', 'i-', 'k-', & - 'l-', 'm-', 'n-'/ + 'l-', 'm-', 'n-'/ DATA (L1(I,1),I=0,10)/ 's ', 'p ', 'd ', 'f ', 'g ', 'h ', 'i ', 'k ', & - 'l ', 'm ', 'n '/ + 'l ', 'm ', 'n '/ ! The value of antmax(l-number,x) is the maximum number of electrons ! in the orbital, x represents +/- coupling of s- and l- number - DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ - DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ + DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ + DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ ! The value of koppl(l-number,number of electrons,x) is the number of ! possible couplings for a certain orbital. If the orbital is ! populated with more than half of the maximal number of electrons ! the index "number of electrons" should be substituted with ! "antmax(l-number) - number of electrons". - DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ ! l=0 - DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ - DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ ! l=1 - DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ - DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ ! l=2 - DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ - DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ ! l=3 - DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ - DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ ! l=4 - DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ - DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ ! l=5 - DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ - DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ ! l=6 - DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ - DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ ! l=7 - DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ - DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ ! l=8 - DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ - DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ ! l=9 - DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ - DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ + DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ ! l=10 - + ! JKVANT(l-number, +/-, number of electrons, coupling number) is 2*J-number - - DATA JKVANT(0,0,0,1)/ 0/ + + DATA JKVANT(0,0,0,1)/ 0/ ! data SENIOR(0,0,0,1) / 0/ - DATA SENIOR(0,0,0,1)/ -1/ + DATA SENIOR(0,0,0,1)/ -1/ ! l=0 #=0 - DATA JKVANT(0,0,1,1)/ 1/ + DATA JKVANT(0,0,1,1)/ 1/ ! data SENIOR(0,0,1,1) / 1/ - DATA SENIOR(0,0,1,1)/ -1/ + DATA SENIOR(0,0,1,1)/ -1/ ! l=0 #=1 - DATA JKVANT(1,0,0,1)/ 0/ + DATA JKVANT(1,0,0,1)/ 0/ ! data SENIOR(1,0,0,1) / 0/ - DATA SENIOR(1,0,0,1)/ -1/ + DATA SENIOR(1,0,0,1)/ -1/ ! l=1 #=0 - - DATA JKVANT(1,0,1,1)/ 1/ + DATA JKVANT(1,0,1,1)/ 1/ ! data SENIOR(1,0,1,1) / 1/ - DATA SENIOR(1,0,1,1)/ -1/ + DATA SENIOR(1,0,1,1)/ -1/ ! l=1 #=1 - - DATA JKVANT(1,1,0,1)/ 0/ + DATA JKVANT(1,1,0,1)/ 0/ ! data SENIOR(1,1,0,1) / 0/ - DATA SENIOR(1,1,0,1)/ -1/ + DATA SENIOR(1,1,0,1)/ -1/ ! l=1 #=0 + - DATA JKVANT(1,1,1,1)/ 3/ + DATA JKVANT(1,1,1,1)/ 3/ ! data SENIOR(1,1,1,1) / 1/ - DATA SENIOR(1,1,1,1)/ -1/ + DATA SENIOR(1,1,1,1)/ -1/ ! l=1 #=1 + - DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(1,1,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ ! l=1 #=2 + - DATA JKVANT(2,0,0,1)/ 0/ + DATA JKVANT(2,0,0,1)/ 0/ ! data SENIOR(2,0,0,1) / 0/ - DATA SENIOR(2,0,0,1)/ -1/ + DATA SENIOR(2,0,0,1)/ -1/ ! l=2 #=0 - - DATA JKVANT(2,0,1,1)/ 3/ + DATA JKVANT(2,0,1,1)/ 3/ ! data SENIOR(2,0,1,1) / 1/ - DATA SENIOR(2,0,1,1)/ -1/ + DATA SENIOR(2,0,1,1)/ -1/ ! l=2 #=1 - - DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(2,0,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ ! l=2 #=2 - - DATA JKVANT(2,1,0,1)/ 0/ + DATA JKVANT(2,1,0,1)/ 0/ ! data SENIOR(2,1,0,1) / 0/ - DATA SENIOR(2,1,0,1)/ -1/ + DATA SENIOR(2,1,0,1)/ -1/ ! l=2 #=0 + - DATA JKVANT(2,1,1,1)/ 5/ + DATA JKVANT(2,1,1,1)/ 5/ ! data SENIOR(2,1,1,1) / 1/ - DATA SENIOR(2,1,1,1)/ -1/ + DATA SENIOR(2,1,1,1)/ -1/ ! l=2 #=1 + - DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(2,1,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ ! l=2 #=2 + - DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(2,1,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ ! l=2 #=3 + - DATA JKVANT(3,0,0,1)/ 0/ + DATA JKVANT(3,0,0,1)/ 0/ ! data SENIOR(3,0,0,1) / 0/ - DATA SENIOR(3,0,0,1)/ -1/ + DATA SENIOR(3,0,0,1)/ -1/ ! l=3 #=0 - - DATA JKVANT(3,0,1,1)/ 5/ + DATA JKVANT(3,0,1,1)/ 5/ ! data SENIOR(3,0,1,1) / 1/ - DATA SENIOR(3,0,1,1)/ -1/ + DATA SENIOR(3,0,1,1)/ -1/ ! l=3 #=1 - - DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(3,0,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ ! l=3 #=2 - - DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(3,0,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ ! l=3 #=3 - - DATA JKVANT(3,1,0,1)/ 0/ + DATA JKVANT(3,1,0,1)/ 0/ ! data SENIOR(3,1,0,1) / 0/ - DATA SENIOR(3,1,0,1)/ -1/ + DATA SENIOR(3,1,0,1)/ -1/ ! l=3 #=0 + - DATA JKVANT(3,1,1,1)/ 7/ + DATA JKVANT(3,1,1,1)/ 7/ ! data SENIOR(3,1,1,1) / 1/ - DATA SENIOR(3,1,1,1)/ -1/ + DATA SENIOR(3,1,1,1)/ -1/ ! l=3 #=1 + - DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(3,1,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=3 #=2 + - DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(3,1,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=3 #=3 + - DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(3,1,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=3 #=4 + - DATA JKVANT(4,0,0,1)/ 0/ + DATA JKVANT(4,0,0,1)/ 0/ ! data SENIOR(4,0,0,1) / 0/ - DATA SENIOR(4,0,0,1)/ -1/ + DATA SENIOR(4,0,0,1)/ -1/ ! l=4 #=0 - - DATA JKVANT(4,0,1,1)/ 7/ + DATA JKVANT(4,0,1,1)/ 7/ ! data SENIOR(4,0,1,1) / 1/ - DATA SENIOR(4,0,1,1)/ -1/ + DATA SENIOR(4,0,1,1)/ -1/ ! l=4 #=1 - - DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(4,0,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=4 #=2 - - DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(4,0,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=4 #=3 - - DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(4,0,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=4 #=4 - - DATA JKVANT(4,1,0,1)/ 0/ + DATA JKVANT(4,1,0,1)/ 0/ ! data SENIOR(4,1,0,1) / 0/ - DATA SENIOR(4,1,0,1)/ -1/ + DATA SENIOR(4,1,0,1)/ -1/ ! l=4 #=0 + - DATA JKVANT(4,1,1,1)/ 9/ + DATA JKVANT(4,1,1,1)/ 9/ ! data SENIOR(4,1,1,1) / 1/ - DATA SENIOR(4,1,1,1)/ -1/ + DATA SENIOR(4,1,1,1)/ -1/ ! l=4 #=1 + - DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(4,1,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=4 #=2 + - DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(4,1,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=4 #=3 + DATA (JKVANT(4,1,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(4,1,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(4,1,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=4 #=4 + DATA (JKVANT(4,1,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(4,1,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(4,1,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=4 #=5 + - DATA JKVANT(5,0,0,1)/ 0/ + DATA JKVANT(5,0,0,1)/ 0/ ! data SENIOR(5,0,0,1) / 0/ - DATA SENIOR(5,0,0,1)/ -1/ + DATA SENIOR(5,0,0,1)/ -1/ ! l=5 #=0 - - DATA JKVANT(5,0,1,1)/ 9/ + DATA JKVANT(5,0,1,1)/ 9/ ! data SENIOR(5,0,1,1) / 1/ - DATA SENIOR(5,0,1,1)/ -1/ + DATA SENIOR(5,0,1,1)/ -1/ ! l=5 #=1 - - DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(5,0,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=5 #=2 - - DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(5,0,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=5 #=3 - DATA (JKVANT(5,0,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(5,0,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(5,0,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=5 #=4 - DATA (JKVANT(5,0,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(5,0,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(5,0,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=5 #=5 - - DATA JKVANT(5,1,0,1)/ 0/ + DATA JKVANT(5,1,0,1)/ 0/ ! data SENIOR(5,1,0,1) / 0/ - DATA SENIOR(5,1,0,1)/ -1/ + DATA SENIOR(5,1,0,1)/ -1/ ! l=5 #=0 + - DATA JKVANT(5,1,1,1)/ 11/ + DATA JKVANT(5,1,1,1)/ 11/ ! data SENIOR(5,1,1,1) / 1/ - DATA SENIOR(5,1,1,1)/ -1/ + DATA SENIOR(5,1,1,1)/ -1/ ! l=5 #=1 + - DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ ! data (SENIOR(5,1,2,i),i=1,6) / 0, 2, 2, 2, 2, 2/ - DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=5 #=2 + - DATA JKVANT(6,0,0,1)/ 0/ - DATA SENIOR(6,0,0,1)/ 0/ + DATA JKVANT(6,0,0,1)/ 0/ + DATA SENIOR(6,0,0,1)/ 0/ ! l=6 #=0 - - DATA JKVANT(6,0,1,1)/ 11/ - DATA SENIOR(6,0,1,1)/ 1/ + DATA JKVANT(6,0,1,1)/ 11/ + DATA SENIOR(6,0,1,1)/ 1/ ! l=6 #=1 - - DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ - DATA (SENIOR(6,0,2,I),I=1,6)/ 0, 2, 2, 2, 2, 2/ + DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (SENIOR(6,0,2,I),I=1,6)/ 0, 2, 2, 2, 2, 2/ ! l=6 #=2 - - DATA JKVANT(6,1,0,1)/ 0/ - DATA SENIOR(6,1,0,1)/ 0/ + DATA JKVANT(6,1,0,1)/ 0/ + DATA SENIOR(6,1,0,1)/ 0/ ! l=6 #=0 + - DATA JKVANT(6,1,1,1)/ 13/ - DATA SENIOR(6,1,1,1)/ 1/ + DATA JKVANT(6,1,1,1)/ 13/ + DATA SENIOR(6,1,1,1)/ 1/ ! l=6 #=1 + - DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ - DATA (SENIOR(6,1,2,I),I=1,7)/ 0, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (SENIOR(6,1,2,I),I=1,7)/ 0, 2, 2, 2, 2, 2, 2/ ! l=6 #=2 + - DATA JKVANT(7,0,0,1)/ 0/ - DATA SENIOR(7,0,0,1)/ 0/ + DATA JKVANT(7,0,0,1)/ 0/ + DATA SENIOR(7,0,0,1)/ 0/ ! l=7 #=0 - - DATA JKVANT(7,0,1,1)/ 13/ - DATA SENIOR(7,0,1,1)/ 1/ + DATA JKVANT(7,0,1,1)/ 13/ + DATA SENIOR(7,0,1,1)/ 1/ ! l=7 #=1 - - DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ - DATA (SENIOR(7,0,2,I),I=1,7)/ 0, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (SENIOR(7,0,2,I),I=1,7)/ 0, 2, 2, 2, 2, 2, 2/ ! l=7 #=2 - - DATA JKVANT(7,1,0,1)/ 0/ - DATA SENIOR(7,1,0,1)/ 0/ + DATA JKVANT(7,1,0,1)/ 0/ + DATA SENIOR(7,1,0,1)/ 0/ ! l=7 #=0 + - DATA JKVANT(7,1,1,1)/ 15/ - DATA SENIOR(7,1,1,1)/ 1/ + DATA JKVANT(7,1,1,1)/ 15/ + DATA SENIOR(7,1,1,1)/ 1/ ! l=7 #=1 + - DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ - DATA (SENIOR(7,1,2,I),I=1,8)/ 0, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (SENIOR(7,1,2,I),I=1,8)/ 0, 2, 2, 2, 2, 2, 2, 2/ ! l=7 #=2 + - DATA JKVANT(8,0,0,1)/ 0/ - DATA SENIOR(8,0,0,1)/ 0/ + DATA JKVANT(8,0,0,1)/ 0/ + DATA SENIOR(8,0,0,1)/ 0/ ! l=8 #=0 - - DATA JKVANT(8,0,1,1)/ 15/ - DATA SENIOR(8,0,1,1)/ 1/ + DATA JKVANT(8,0,1,1)/ 15/ + DATA SENIOR(8,0,1,1)/ 1/ ! l=8 #=1 - - DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ - DATA (SENIOR(8,0,2,I),I=1,8)/ 0, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (SENIOR(8,0,2,I),I=1,8)/ 0, 2, 2, 2, 2, 2, 2, 2/ ! l=8 #=2 - - DATA JKVANT(8,1,0,1)/ 0/ - DATA SENIOR(8,1,0,1)/ 0/ + DATA JKVANT(8,1,0,1)/ 0/ + DATA SENIOR(8,1,0,1)/ 0/ ! l=8 #=0 + - DATA JKVANT(8,1,1,1)/ 17/ - DATA SENIOR(8,1,1,1)/ 1/ + DATA JKVANT(8,1,1,1)/ 17/ + DATA SENIOR(8,1,1,1)/ 1/ ! l=8 #=1 + - DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ - DATA (SENIOR(8,1,2,I),I=1,9)/ 0, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (SENIOR(8,1,2,I),I=1,9)/ 0, 2, 2, 2, 2, 2, 2, 2, 2/ ! l=8 #=2 + - DATA JKVANT(9,0,0,1)/ 0/ - DATA SENIOR(9,0,0,1)/ 0/ + DATA JKVANT(9,0,0,1)/ 0/ + DATA SENIOR(9,0,0,1)/ 0/ ! l=9 #=0 - - DATA JKVANT(9,0,1,1)/ 17/ - DATA SENIOR(9,0,1,1)/ 1/ + DATA JKVANT(9,0,1,1)/ 17/ + DATA SENIOR(9,0,1,1)/ 1/ ! l=9 #=1 - - DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ - DATA (SENIOR(9,0,2,I),I=1,9)/ 0, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (SENIOR(9,0,2,I),I=1,9)/ 0, 2, 2, 2, 2, 2, 2, 2, 2/ ! l=9 #=2 - - DATA JKVANT(9,1,0,1)/ 0/ - DATA SENIOR(9,1,0,1)/ 0/ + DATA JKVANT(9,1,0,1)/ 0/ + DATA SENIOR(9,1,0,1)/ 0/ ! l=9 #=0 + - DATA JKVANT(9,1,1,1)/ 19/ - DATA SENIOR(9,1,1,1)/ 1/ + DATA JKVANT(9,1,1,1)/ 19/ + DATA SENIOR(9,1,1,1)/ 1/ ! l=9 #=1 + - DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ - DATA (SENIOR(9,1,2,I),I=1,10)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (SENIOR(9,1,2,I),I=1,10)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ ! l=9 #=2 + - DATA JKVANT(10,0,0,1)/ 0/ - DATA SENIOR(10,0,0,1)/ 0/ + DATA JKVANT(10,0,0,1)/ 0/ + DATA SENIOR(10,0,0,1)/ 0/ ! l=10 #=0 - - DATA JKVANT(10,0,1,1)/ 19/ - DATA SENIOR(10,0,1,1)/ 1/ + DATA JKVANT(10,0,1,1)/ 19/ + DATA SENIOR(10,0,1,1)/ 1/ ! l=10 #=1 - - DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ - DATA (SENIOR(10,0,2,I),I=1,10)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (SENIOR(10,0,2,I),I=1,10)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ ! l=10 #=2 - - DATA JKVANT(10,1,0,1)/ 0/ - DATA SENIOR(10,1,0,1)/ 0/ + DATA JKVANT(10,1,0,1)/ 0/ + DATA SENIOR(10,1,0,1)/ 0/ ! l=10 #=0 + - DATA JKVANT(10,1,1,1)/ 21/ - DATA SENIOR(10,1,1,1)/ 1/ + DATA JKVANT(10,1,1,1)/ 21/ + DATA SENIOR(10,1,1,1)/ 1/ ! l=10 #=1 + - DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ - DATA (SENIOR(10,1,2,I),I=1,11)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ + DATA (SENIOR(10,1,2,I),I=1,11)/ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ ! l=10 #=2 + - IF (FIRST) THEN - FIL = FIL_1 - ELSE - FIL = FIL_2 - ENDIF - ANTKO = 1 - POS = 0 - DO I = 1, 110 - N = POSN(I) - L = POSL(I) + IF (FIRST) THEN + FIL = FIL_1 + ELSE + FIL = FIL_2 + ENDIF + ANTKO = 1 + POS = 0 + DO I = 1, 110 + N = POSN(I) + L = POSL(I) !Jacek mailed the fix 98-10-29 - IF (N < 10) THEN - DO K = 0, MIN(L,1) + IF (N < 10) THEN + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ELSE - DO K = 0, MIN(L,1) + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ELSE + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - N1 = MOD(N,10) - N10 = N/10 - RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ENDIF - END DO - - IF (POS == 0) RETURN - DO I1 = 1, ANTKO(1) - DO I2 = 1, ANTKO(2) - DO I3 = 1, ANTKO(3) - DO I4 = 1, ANTKO(4) - DO I5 = 1, ANTKO(5) - DO I6 = 1, ANTKO(6) - DO I7 = 1, ANTKO(7) - DO I8 = 1, ANTKO(8) - DO I9 = 1, ANTKO(9) - DO I10 = 1, ANTKO(10) - DO I11 = 1, ANTKO(11) - DO I12 = 1, ANTKO(12) - DO I13 = 1, ANTKO(13) - DO I14 = 1, ANTKO(14) - DO I15 = 1, ANTKO(15) - DO I16 = 1, ANTKO(16) - DO I17 = 1, ANTKO(17) - DO I18 = 1, ANTKO(18) - DO I19 = 1, ANTKO(19) - DO I20 = 1, ANTKO(20) - - J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) - S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) - IF (POS == 1) THEN - IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:9) - WRITE (FIL, 999) RAD2(1:9) - WRITE (FIL, 999) RAD3(1:11) - CF = CF + 1 - ENDIF - ELSE - - DO RESJ = MINJ, MAXJ, 2 - JK(POS-1) = RESJ - J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) - S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) - IF (POS == 2) THEN + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + N1 = MOD(N,10) + N10 = N/10 + RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ENDIF + END DO + + IF (POS == 0) RETURN + DO I1 = 1, ANTKO(1) + DO I2 = 1, ANTKO(2) + DO I3 = 1, ANTKO(3) + DO I4 = 1, ANTKO(4) + DO I5 = 1, ANTKO(5) + DO I6 = 1, ANTKO(6) + DO I7 = 1, ANTKO(7) + DO I8 = 1, ANTKO(8) + DO I9 = 1, ANTKO(9) + DO I10 = 1, ANTKO(10) + DO I11 = 1, ANTKO(11) + DO I12 = 1, ANTKO(12) + DO I13 = 1, ANTKO(13) + DO I14 = 1, ANTKO(14) + DO I15 = 1, ANTKO(15) + DO I16 = 1, ANTKO(16) + DO I17 = 1, ANTKO(17) + DO I18 = 1, ANTKO(18) + DO I19 = 1, ANTKO(19) + DO I20 = 1, ANTKO(20) + + J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) + S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) + IF (POS == 1) THEN + IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:9) + WRITE (FIL, 999) RAD2(1:9) + WRITE (FIL, 999) RAD3(1:11) + CF = CF + 1 + ENDIF + ELSE + + DO RESJ = MINJ, MAXJ, 2 + JK(POS-1) = RESJ + J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) + S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) + IF (POS == 2) THEN IF (RESJ>=ABS(J(1)-J(2)) .AND. RESJ<=J(1)+J& - (2)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:18) - WRITE (FIL, 999) RAD2(1:18) - WRITE (FIL, 999) RAD3(1:20) - CF = CF + 1 - ENDIF - ELSE - - J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) - S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) - DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 - JK(1) = JK1 - IF (POS == 3) THEN + (2)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:18) + WRITE (FIL, 999) RAD2(1:18) + WRITE (FIL, 999) RAD3(1:20) + CF = CF + 1 + ENDIF + ELSE + + J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) + S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) + DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 + JK(1) = JK1 + IF (POS == 3) THEN IF (RESJ>=ABS(JK1 - J(3)) .AND. RESJ<=JK1+J& - (3)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:27) - WRITE (FIL, 999) RAD2(1:27) - WRITE (FIL, 999) RAD3(1:29) - CF = CF + 1 - ENDIF - ELSE - - J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) - S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) - DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 - JK(2) = JK2 - IF (POS == 4) THEN + (3)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:27) + WRITE (FIL, 999) RAD2(1:27) + WRITE (FIL, 999) RAD3(1:29) + CF = CF + 1 + ENDIF + ELSE + + J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) + S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) + DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 + JK(2) = JK2 + IF (POS == 4) THEN IF (RESJ>=ABS(JK2 - J(4)) .AND. RESJ<=JK2+J& - (4)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:36) - WRITE (FIL, 999) RAD2(1:36) - WRITE (FIL, 999) RAD3(1:38) - CF = CF + 1 - ENDIF - ELSE - - J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) - S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) - DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 - JK(3) = JK3 - IF (POS == 5) THEN + (4)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:36) + WRITE (FIL, 999) RAD2(1:36) + WRITE (FIL, 999) RAD3(1:38) + CF = CF + 1 + ENDIF + ELSE + + J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) + S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) + DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 + JK(3) = JK3 + IF (POS == 5) THEN IF (RESJ>=ABS(JK3 - J(5)) .AND. RESJ<=JK3+J& - (5)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:45) - WRITE (FIL, 999) RAD2(1:45) - WRITE (FIL, 999) RAD3(1:47) - CF = CF + 1 - ENDIF - ELSE - - J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) - S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) - DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 - JK(4) = JK4 - IF (POS == 6) THEN + (5)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:45) + WRITE (FIL, 999) RAD2(1:45) + WRITE (FIL, 999) RAD3(1:47) + CF = CF + 1 + ENDIF + ELSE + + J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) + S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) + DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 + JK(4) = JK4 + IF (POS == 6) THEN IF (RESJ>=ABS(JK4 - J(6)) .AND. RESJ<=JK4+J& - (6)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:54) - WRITE (FIL, 999) RAD2(1:54) - WRITE (FIL, 999) RAD3(1:56) - CF = CF + 1 - ENDIF - ELSE - - J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) - S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) - DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 - JK(5) = JK5 - IF (POS == 7) THEN + (6)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:54) + WRITE (FIL, 999) RAD2(1:54) + WRITE (FIL, 999) RAD3(1:56) + CF = CF + 1 + ENDIF + ELSE + + J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) + S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) + DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 + JK(5) = JK5 + IF (POS == 7) THEN IF (RESJ>=ABS(JK5 - J(7)) .AND. RESJ<=JK5+J& - (7)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:63) - WRITE (FIL, 999) RAD2(1:63) - WRITE (FIL, 999) RAD3(1:65) - CF = CF + 1 - ENDIF - ELSE - - J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) - S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) - DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 - JK(6) = JK6 - IF (POS == 8) THEN + (7)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:63) + WRITE (FIL, 999) RAD2(1:63) + WRITE (FIL, 999) RAD3(1:65) + CF = CF + 1 + ENDIF + ELSE + + J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) + S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) + DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 + JK(6) = JK6 + IF (POS == 8) THEN IF (RESJ>=ABS(JK6 - J(8)) .AND. RESJ<=JK6+J& - (8)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:72) - WRITE (FIL, 999) RAD2(1:72) - WRITE (FIL, 999) RAD3(1:74) - CF = CF + 1 - ENDIF - ELSE - - J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) - S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) - DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 - JK(7) = JK7 - IF (POS == 9) THEN + (8)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:72) + WRITE (FIL, 999) RAD2(1:72) + WRITE (FIL, 999) RAD3(1:74) + CF = CF + 1 + ENDIF + ELSE + + J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) + S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) + DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 + JK(7) = JK7 + IF (POS == 9) THEN IF (RESJ>=ABS(JK7 - J(9)) .AND. RESJ<=JK7+J& - (9)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:81) - WRITE (FIL, 999) RAD2(1:81) - WRITE (FIL, 999) RAD3(1:83) - CF = CF + 1 - ENDIF - ELSE - + (9)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:81) + WRITE (FIL, 999) RAD2(1:81) + WRITE (FIL, 999) RAD3(1:83) + CF = CF + 1 + ENDIF + ELSE + J(10) = JKVANT(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) + ,I10) S(10) = SENIOR(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) - DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 - JK(8) = JK8 - IF (POS == 10) THEN + ,I10) + DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 + JK(8) = JK8 + IF (POS == 10) THEN IF (RESJ>=ABS(JK8 - J(10)) .AND. RESJ<=JK8+& - J(10)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:90) - WRITE (FIL, 999) RAD2(1:90) - WRITE (FIL, 999) RAD3(1:92) - CF = CF + 1 - ENDIF - ELSE - + J(10)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:90) + WRITE (FIL, 999) RAD2(1:90) + WRITE (FIL, 999) RAD3(1:92) + CF = CF + 1 + ENDIF + ELSE + J(11) = JKVANT(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) + ,I11) S(11) = SENIOR(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) - DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 - JK(9) = JK9 - IF (POS == 11) THEN + ,I11) + DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 + JK(9) = JK9 + IF (POS == 11) THEN IF (RESJ>=ABS(JK9 - J(11)) .AND. RESJ<=JK9+& - J(11)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:99) - WRITE (FIL, 999) RAD2(1:99) - WRITE (FIL, 999) RAD3(1:101) - CF = CF + 1 - ENDIF - ELSE - + J(11)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:99) + WRITE (FIL, 999) RAD2(1:99) + WRITE (FIL, 999) RAD3(1:101) + CF = CF + 1 + ENDIF + ELSE + J(12) = JKVANT(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) + ,I12) S(12) = SENIOR(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) - DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 - JK(10) = JK10 - IF (POS == 12) THEN + ,I12) + DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 + JK(10) = JK10 + IF (POS == 12) THEN IF (RESJ>=ABS(JK10 - J(12)) .AND. RESJ<=& - JK10+J(12)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:108) - WRITE (FIL, 999) RAD2(1:108) - WRITE (FIL, 999) RAD3(1:110) - CF = CF + 1 - ENDIF - ELSE - + JK10+J(12)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:108) + WRITE (FIL, 999) RAD2(1:108) + WRITE (FIL, 999) RAD3(1:110) + CF = CF + 1 + ENDIF + ELSE + J(13) = JKVANT(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) S(13) = SENIOR(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) DO JK11 = ABS(JK10 - J(12)), JK10 + J(12), & - 2 - JK(11) = JK11 - IF (POS == 13) THEN + 2 + JK(11) = JK11 + IF (POS == 13) THEN IF (RESJ>=ABS(JK11 - J(13)) .AND. RESJ<=& - JK11+J(13)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:117) - WRITE (FIL, 999) RAD2(1:117) - WRITE (FIL, 999) RAD3(1:119) - CF = CF + 1 - ENDIF - ELSE - + JK11+J(13)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:117) + WRITE (FIL, 999) RAD2(1:117) + WRITE (FIL, 999) RAD3(1:119) + CF = CF + 1 + ENDIF + ELSE + J(14) = JKVANT(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) S(14) = SENIOR(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) DO JK12 = ABS(JK11 - J(13)), JK11 + J(13), & - 2 - JK(12) = JK12 - IF (POS == 14) THEN + 2 + JK(12) = JK12 + IF (POS == 14) THEN IF (RESJ>=ABS(JK12 - J(14)) .AND. RESJ<=& - JK12+J(14)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:126) - WRITE (FIL, 999) RAD2(1:126) - WRITE (FIL, 999) RAD3(1:128) - CF = CF + 1 - ENDIF - ELSE - + JK12+J(14)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:126) + WRITE (FIL, 999) RAD2(1:126) + WRITE (FIL, 999) RAD3(1:128) + CF = CF + 1 + ENDIF + ELSE + J(15) = JKVANT(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) S(15) = SENIOR(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) DO JK13 = ABS(JK12 - J(14)), JK12 + J(14), & - 2 - JK(13) = JK13 - IF (POS == 15) THEN + 2 + JK(13) = JK13 + IF (POS == 15) THEN IF (RESJ>=ABS(JK13 - J(15)) .AND. RESJ<=& - JK13+J(15)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:135) - WRITE (FIL, 999) RAD2(1:135) - WRITE (FIL, 999) RAD3(1:137) - CF = CF + 1 - ENDIF - ELSE - + JK13+J(15)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:135) + WRITE (FIL, 999) RAD2(1:135) + WRITE (FIL, 999) RAD3(1:137) + CF = CF + 1 + ENDIF + ELSE + J(16) = JKVANT(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) S(16) = SENIOR(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) DO JK14 = ABS(JK13 - J(15)), JK13 + J(15), & - 2 - JK(14) = JK14 - IF (POS == 16) THEN + 2 + JK(14) = JK14 + IF (POS == 16) THEN IF (RESJ>=ABS(JK14 - J(16)) .AND. RESJ<=& - JK14+J(16)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:144) - WRITE (FIL, 999) RAD2(1:144) - WRITE (FIL, 999) RAD3(1:146) - CF = CF + 1 - ENDIF - ELSE - + JK14+J(16)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:144) + WRITE (FIL, 999) RAD2(1:144) + WRITE (FIL, 999) RAD3(1:146) + CF = CF + 1 + ENDIF + ELSE + J(17) = JKVANT(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) S(17) = SENIOR(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) DO JK15 = ABS(JK14 - J(16)), JK14 + J(16), & - 2 - JK(15) = JK15 - IF (POS == 17) THEN + 2 + JK(15) = JK15 + IF (POS == 17) THEN IF (RESJ>=ABS(JK15 - J(17)) .AND. RESJ<=& - JK15+J(17)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:153) - WRITE (FIL, 999) RAD2(1:153) - WRITE (FIL, 999) RAD3(1:155) - CF = CF + 1 - ENDIF - ELSE - + JK15+J(17)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:153) + WRITE (FIL, 999) RAD2(1:153) + WRITE (FIL, 999) RAD3(1:155) + CF = CF + 1 + ENDIF + ELSE + J(18) = JKVANT(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) S(18) = SENIOR(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) DO JK16 = ABS(JK15 - J(17)), JK15 + J(17), & - 2 - JK(16) = JK16 - IF (POS == 18) THEN + 2 + JK(16) = JK16 + IF (POS == 18) THEN IF (RESJ>=ABS(JK16 - J(18)) .AND. RESJ<=& - JK16+J(18)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:162) - WRITE (FIL, 999) RAD2(1:162) - WRITE (FIL, 999) RAD3(1:164) - CF = CF + 1 - ENDIF - ELSE - + JK16+J(18)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:162) + WRITE (FIL, 999) RAD2(1:162) + WRITE (FIL, 999) RAD3(1:164) + CF = CF + 1 + ENDIF + ELSE + J(19) = JKVANT(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) S(19) = SENIOR(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) DO JK17 = ABS(JK16 - J(18)), JK16 + J(18), & - 2 - JK(17) = JK17 - IF (POS == 19) THEN + 2 + JK(17) = JK17 + IF (POS == 19) THEN IF (RESJ>=ABS(JK17 - J(19)) .AND. RESJ<=& - JK17+J(19)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:171) - WRITE (FIL, 999) RAD2(1:171) - WRITE (FIL, 999) RAD3(1:173) - CF = CF + 1 - ENDIF - ELSE - + JK17+J(19)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:171) + WRITE (FIL, 999) RAD2(1:171) + WRITE (FIL, 999) RAD3(1:173) + CF = CF + 1 + ENDIF + ELSE + J(20) = JKVANT(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) S(20) = SENIOR(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) DO JK18 = ABS(JK17 - J(19)), JK17 + J(19), & - 2 + 2 IF (RESJJK18+J& - (20)) CYCLE - JK(18) = JK18 - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:180) - WRITE (FIL, 999) RAD2(1:180) - WRITE (FIL, 999) RAD3(1:182) - CF = CF + 1 - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - 999 FORMAT(2A) - RETURN - END SUBROUTINE GEN + (20)) CYCLE + JK(18) = JK18 + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:180) + WRITE (FIL, 999) RAD2(1:180) + WRITE (FIL, 999) RAD3(1:182) + CF = CF + 1 + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + 999 FORMAT(2A) + RETURN + END SUBROUTINE GEN diff --git a/src/appl/jjgen90/gen_I.f90 b/src/appl/jjgen90/gen_I.f90 index 7f3af08fc..532bcf82a 100644 --- a/src/appl/jjgen90/gen_I.f90 +++ b/src/appl/jjgen90/gen_I.f90 @@ -1,16 +1,16 @@ - MODULE gen_I + MODULE gen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE gen (ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL - integer, INTENT(IN) :: SKAL - integer, INTENT(INOUT) :: CF - logical, INTENT(IN) :: FIRST - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ - integer :: PAR - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE gen (ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL + integer, INTENT(IN) :: SKAL + integer, INTENT(INOUT) :: CF + logical, INTENT(IN) :: FIRST + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ + integer :: PAR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/genb.f90 b/src/appl/jjgen90/genb.f90 index a255ab94d..d64cbd940 100644 --- a/src/appl/jjgen90/genb.f90 +++ b/src/appl/jjgen90/genb.f90 @@ -1,891 +1,891 @@ ! last edited July 31, 1996 - SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE kopp1_I - USE kopp2_I + USE kopp1_I + USE kopp2_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: SKAL - INTEGER , INTENT(INOUT) :: CF - INTEGER , INTENT(IN) :: MINJ - INTEGER , INTENT(IN) :: MAXJ - INTEGER :: PAR - LOGICAL , INTENT(IN) :: FIRST - INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) - INTEGER , INTENT(IN) :: POSN(110) - INTEGER , INTENT(IN) :: POSL(110) + INTEGER , INTENT(IN) :: SKAL + INTEGER , INTENT(INOUT) :: CF + INTEGER , INTENT(IN) :: MINJ + INTEGER , INTENT(IN) :: MAXJ + INTEGER :: PAR + LOGICAL , INTENT(IN) :: FIRST + INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) + INTEGER , INTENT(IN) :: POSN(110) + INTEGER , INTENT(IN) :: POSL(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: FIL_1 = 7 - INTEGER, PARAMETER :: FIL_2 = 8 + INTEGER, PARAMETER :: FIL_1 = 7 + INTEGER, PARAMETER :: FIL_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT - INTEGER , DIMENSION(0:10,0:1) :: ANTMAX - INTEGER :: POS, I, N, L, K - INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL + INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT + INTEGER , DIMENSION(0:10,0:1) :: ANTMAX + INTEGER :: POS, I, N, L, K + INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL INTEGER :: I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, I11, I12, I13, I14, & - I15, I16, I17, I18, I19, I20 - INTEGER , DIMENSION(20) :: PLUS, S + I15, I16, I17, I18, I19, I20 + INTEGER , DIMENSION(20) :: PLUS, S INTEGER :: RESJ, JK1, JK2, JK3, JK4, JK5, JK6, JK7, JK8, JK9, JK10, JK11& - , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL - INTEGER , DIMENSION(20) :: ANTKO - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR - INTEGER :: N1, N10 - CHARACTER :: RAD1*200, RAD2*200, RAD3*200 - CHARACTER, DIMENSION(0:10,0:1) :: L1*2 + , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL + INTEGER , DIMENSION(20) :: ANTKO + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR + INTEGER :: N1, N10 + CHARACTER :: RAD1*200, RAD2*200, RAD3*200 + CHARACTER, DIMENSION(0:10,0:1) :: L1*2 !----------------------------------------------- DATA (L1(I,0),I=0,10)/ 's ', 'p-', 'd-', 'f-', 'g-', 'h-', 'i-', 'k-', & - 'l-', 'm-', 'n-'/ + 'l-', 'm-', 'n-'/ DATA (L1(I,1),I=0,10)/ 's ', 'p ', 'd ', 'f ', 'g ', 'h ', 'i ', 'k ', & - 'l ', 'm ', 'n '/ + 'l ', 'm ', 'n '/ ! The value of antmax(l-number,x) is the maximum number of electrons ! in the orbital, x represents +/- coupling of s- and l- number - DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ - DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ + DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ + DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ ! The value of koppl(l-number,number of electrons,x) is the number of ! possible couplings for a certain orbital. If the orbital is ! populated with more than half of the maximal number of electrons ! the index "number of electrons" should be substituted with ! "antmax(l-number) - number of electrons". - DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ ! l=0 - DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ - DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ ! l=1 - DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ - DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ ! l=2 - DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ - DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ ! l=3 - DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ - DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ ! l=4 - DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ - DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ ! l=5 - DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ - DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ ! l=6 - DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ - DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ ! l=7 - DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ - DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ ! l=8 - DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ - DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ ! l=9 - DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ - DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ + DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ ! l=10 - + ! JKVANT(l-number, +/-, number of electrons, coupling number) is 2*J-number - - DATA JKVANT(0,0,0,1)/ 0/ + + DATA JKVANT(0,0,0,1)/ 0/ ! data SENIOR(0,0,0,1) / 0/ - DATA SENIOR(0,0,0,1)/ -1/ + DATA SENIOR(0,0,0,1)/ -1/ ! l=0 #=0 - DATA JKVANT(0,0,1,1)/ 1/ + DATA JKVANT(0,0,1,1)/ 1/ ! data SENIOR(0,0,1,1) / 1/ - DATA SENIOR(0,0,1,1)/ -1/ + DATA SENIOR(0,0,1,1)/ -1/ ! l=0 #=1 - DATA JKVANT(1,0,0,1)/ 0/ + DATA JKVANT(1,0,0,1)/ 0/ ! data SENIOR(1,0,0,1) / 0/ - DATA SENIOR(1,0,0,1)/ -1/ + DATA SENIOR(1,0,0,1)/ -1/ ! l=1 #=0 - - DATA JKVANT(1,0,1,1)/ 1/ + DATA JKVANT(1,0,1,1)/ 1/ ! data SENIOR(1,0,1,1) / 1/ - DATA SENIOR(1,0,1,1)/ -1/ + DATA SENIOR(1,0,1,1)/ -1/ ! l=1 #=1 - - DATA JKVANT(1,1,0,1)/ 0/ + DATA JKVANT(1,1,0,1)/ 0/ ! data SENIOR(1,1,0,1) / 0/ - DATA SENIOR(1,1,0,1)/ -1/ + DATA SENIOR(1,1,0,1)/ -1/ ! l=1 #=0 + - DATA JKVANT(1,1,1,1)/ 3/ + DATA JKVANT(1,1,1,1)/ 3/ ! data SENIOR(1,1,1,1) / 1/ - DATA SENIOR(1,1,1,1)/ -1/ + DATA SENIOR(1,1,1,1)/ -1/ ! l=1 #=1 + - DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(1,1,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ ! l=1 #=2 + - DATA JKVANT(2,0,0,1)/ 0/ + DATA JKVANT(2,0,0,1)/ 0/ ! data SENIOR(2,0,0,1) / 0/ - DATA SENIOR(2,0,0,1)/ -1/ + DATA SENIOR(2,0,0,1)/ -1/ ! l=2 #=0 - - DATA JKVANT(2,0,1,1)/ 3/ + DATA JKVANT(2,0,1,1)/ 3/ ! data SENIOR(2,0,1,1) / 1/ - DATA SENIOR(2,0,1,1)/ -1/ + DATA SENIOR(2,0,1,1)/ -1/ ! l=2 #=1 - - DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(2,0,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ ! l=2 #=2 - - DATA JKVANT(2,1,0,1)/ 0/ + DATA JKVANT(2,1,0,1)/ 0/ ! data SENIOR(2,1,0,1) / 0/ - DATA SENIOR(2,1,0,1)/ -1/ + DATA SENIOR(2,1,0,1)/ -1/ ! l=2 #=0 + - DATA JKVANT(2,1,1,1)/ 5/ + DATA JKVANT(2,1,1,1)/ 5/ ! data SENIOR(2,1,1,1) / 1/ - DATA SENIOR(2,1,1,1)/ -1/ + DATA SENIOR(2,1,1,1)/ -1/ ! l=2 #=1 + - DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(2,1,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ ! l=2 #=2 + - DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(2,1,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ ! l=2 #=3 + - DATA JKVANT(3,0,0,1)/ 0/ + DATA JKVANT(3,0,0,1)/ 0/ ! data SENIOR(3,0,0,1) / 0/ - DATA SENIOR(3,0,0,1)/ -1/ + DATA SENIOR(3,0,0,1)/ -1/ ! l=3 #=0 - - DATA JKVANT(3,0,1,1)/ 5/ + DATA JKVANT(3,0,1,1)/ 5/ ! data SENIOR(3,0,1,1) / 1/ - DATA SENIOR(3,0,1,1)/ -1/ + DATA SENIOR(3,0,1,1)/ -1/ ! l=3 #=1 - - DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(3,0,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ ! l=3 #=2 - - DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(3,0,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ ! l=3 #=3 - - DATA JKVANT(3,1,0,1)/ 0/ + DATA JKVANT(3,1,0,1)/ 0/ ! data SENIOR(3,1,0,1) / 0/ - DATA SENIOR(3,1,0,1)/ -1/ + DATA SENIOR(3,1,0,1)/ -1/ ! l=3 #=0 + - DATA JKVANT(3,1,1,1)/ 7/ + DATA JKVANT(3,1,1,1)/ 7/ ! data SENIOR(3,1,1,1) / 1/ - DATA SENIOR(3,1,1,1)/ -1/ + DATA SENIOR(3,1,1,1)/ -1/ ! l=3 #=1 + - DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(3,1,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=3 #=2 + - DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(3,1,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=3 #=3 + - DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(3,1,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=3 #=4 + - DATA JKVANT(4,0,0,1)/ 0/ + DATA JKVANT(4,0,0,1)/ 0/ ! data SENIOR(4,0,0,1) / 0/ - DATA SENIOR(4,0,0,1)/ -1/ + DATA SENIOR(4,0,0,1)/ -1/ ! l=4 #=0 - - DATA JKVANT(4,0,1,1)/ 7/ + DATA JKVANT(4,0,1,1)/ 7/ ! data SENIOR(4,0,1,1) / 1/ - DATA SENIOR(4,0,1,1)/ -1/ + DATA SENIOR(4,0,1,1)/ -1/ ! l=4 #=1 - - DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(4,0,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=4 #=2 - - DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(4,0,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=4 #=3 - - DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(4,0,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=4 #=4 - - DATA JKVANT(4,1,0,1)/ 0/ + DATA JKVANT(4,1,0,1)/ 0/ ! data SENIOR(4,1,0,1) / 0/ - DATA SENIOR(4,1,0,1)/ -1/ + DATA SENIOR(4,1,0,1)/ -1/ ! l=4 #=0 + - DATA JKVANT(4,1,1,1)/ 9/ + DATA JKVANT(4,1,1,1)/ 9/ ! data SENIOR(4,1,1,1) / 1/ - DATA SENIOR(4,1,1,1)/ -1/ + DATA SENIOR(4,1,1,1)/ -1/ ! l=4 #=1 + - DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(4,1,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=4 #=2 + - DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(4,1,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=4 #=3 + DATA (JKVANT(4,1,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(4,1,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(4,1,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=4 #=4 + DATA (JKVANT(4,1,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(4,1,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(4,1,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=4 #=5 + - DATA JKVANT(5,0,0,1)/ 0/ + DATA JKVANT(5,0,0,1)/ 0/ ! data SENIOR(5,0,0,1) / 0/ - DATA SENIOR(5,0,0,1)/ -1/ + DATA SENIOR(5,0,0,1)/ -1/ ! l=5 #=0 - - DATA JKVANT(5,0,1,1)/ 9/ + DATA JKVANT(5,0,1,1)/ 9/ ! data SENIOR(5,0,1,1) / 1/ - DATA SENIOR(5,0,1,1)/ -1/ + DATA SENIOR(5,0,1,1)/ -1/ ! l=5 #=1 - - DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(5,0,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=5 #=2 - - DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(5,0,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=5 #=3 - DATA (JKVANT(5,0,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(5,0,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(5,0,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=5 #=4 - DATA (JKVANT(5,0,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(5,0,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(5,0,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=5 #=5 - - DATA JKVANT(5,1,0,1)/ 0/ + DATA JKVANT(5,1,0,1)/ 0/ ! data SENIOR(5,1,0,1) / 0/ - DATA SENIOR(5,1,0,1)/ -1/ + DATA SENIOR(5,1,0,1)/ -1/ ! l=5 #=0 + - DATA JKVANT(5,1,1,1)/ 11/ + DATA JKVANT(5,1,1,1)/ 11/ ! data SENIOR(5,1,1,1) / 1/ - DATA SENIOR(5,1,1,1)/ -1/ + DATA SENIOR(5,1,1,1)/ -1/ ! l=5 #=1 + - DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ ! data (SENIOR(5,1,2,i),i=1,6) / 0, 2, 2, 2, 2, 2/ - DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=5 #=2 + - DATA JKVANT(6,0,0,1)/ 0/ + DATA JKVANT(6,0,0,1)/ 0/ ! data SENIOR(6,0,0,1) / 0/ - DATA SENIOR(6,0,0,1)/ -1/ + DATA SENIOR(6,0,0,1)/ -1/ ! l=6 #=0 - - DATA JKVANT(6,0,1,1)/ 11/ + DATA JKVANT(6,0,1,1)/ 11/ ! data SENIOR(6,0,1,1) / 1/ - DATA SENIOR(6,0,1,1)/ -1/ + DATA SENIOR(6,0,1,1)/ -1/ ! l=6 #=1 - - DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ ! data (SENIOR(6,0,2,i),i=1,6) / 0, 2, 2, 2, 2, 2/ - DATA (SENIOR(6,0,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(6,0,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=6 #=2 - - DATA JKVANT(6,1,0,1)/ 0/ + DATA JKVANT(6,1,0,1)/ 0/ ! data SENIOR(6,1,0,1) / 0/ - DATA SENIOR(6,1,0,1)/ -1/ + DATA SENIOR(6,1,0,1)/ -1/ ! l=6 #=0 + - DATA JKVANT(6,1,1,1)/ 13/ + DATA JKVANT(6,1,1,1)/ 13/ ! data SENIOR(6,1,1,1) / 1/ - DATA SENIOR(6,1,1,1)/ -1/ + DATA SENIOR(6,1,1,1)/ -1/ ! l=6 #=1 + - DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ ! data (SENIOR(6,1,2,i),i=1,7) / 0, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(6,1,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(6,1,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ ! l=6 #=2 + - DATA JKVANT(7,0,0,1)/ 0/ + DATA JKVANT(7,0,0,1)/ 0/ ! data SENIOR(7,0,0,1) / 0/ - DATA SENIOR(7,0,0,1)/ -1/ + DATA SENIOR(7,0,0,1)/ -1/ ! l=7 #=0 - - DATA JKVANT(7,0,1,1)/ 13/ + DATA JKVANT(7,0,1,1)/ 13/ ! data SENIOR(7,0,1,1) / 1/ - DATA SENIOR(7,0,1,1)/ -1/ + DATA SENIOR(7,0,1,1)/ -1/ ! l=7 #=1 - - DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ ! data (SENIOR(7,0,2,i),i=1,7) / 0, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(7,0,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(7,0,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ ! l=7 #=2 - - DATA JKVANT(7,1,0,1)/ 0/ + DATA JKVANT(7,1,0,1)/ 0/ ! data SENIOR(7,1,0,1) / 0/ - DATA SENIOR(7,1,0,1)/ -1/ + DATA SENIOR(7,1,0,1)/ -1/ ! l=7 #=0 + - DATA JKVANT(7,1,1,1)/ 15/ + DATA JKVANT(7,1,1,1)/ 15/ ! data SENIOR(7,1,1,1) / 1/ - DATA SENIOR(7,1,1,1)/ -1/ + DATA SENIOR(7,1,1,1)/ -1/ ! l=7 #=1 + - DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ ! data (SENIOR(7,1,2,i),i=1,8) / 0, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(7,1,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(7,1,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ ! l=7 #=2 + - DATA JKVANT(8,0,0,1)/ 0/ + DATA JKVANT(8,0,0,1)/ 0/ ! data SENIOR(8,0,0,1) / 0/ - DATA SENIOR(8,0,0,1)/ -1/ + DATA SENIOR(8,0,0,1)/ -1/ ! l=8 #=0 - - DATA JKVANT(8,0,1,1)/ 15/ + DATA JKVANT(8,0,1,1)/ 15/ ! data SENIOR(8,0,1,1) / 1/ - DATA SENIOR(8,0,1,1)/ -1/ + DATA SENIOR(8,0,1,1)/ -1/ ! l=8 #=1 - - DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ ! data (SENIOR(8,0,2,i),i=1,8) / 0, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(8,0,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(8,0,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ ! l=8 #=2 - - DATA JKVANT(8,1,0,1)/ 0/ + DATA JKVANT(8,1,0,1)/ 0/ ! data SENIOR(8,1,0,1) / 0/ - DATA SENIOR(8,1,0,1)/ -1/ + DATA SENIOR(8,1,0,1)/ -1/ ! l=8 #=0 + - DATA JKVANT(8,1,1,1)/ 17/ + DATA JKVANT(8,1,1,1)/ 17/ ! data SENIOR(8,1,1,1) / 1/ - DATA SENIOR(8,1,1,1)/ -1/ + DATA SENIOR(8,1,1,1)/ -1/ ! l=8 #=1 + - DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ ! data (SENIOR(8,1,2,i),i=1,9) / 0, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(8,1,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(8,1,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=8 #=2 + - DATA JKVANT(9,0,0,1)/ 0/ + DATA JKVANT(9,0,0,1)/ 0/ ! data SENIOR(9,0,0,1) / 0/ - DATA SENIOR(9,0,0,1)/ -1/ + DATA SENIOR(9,0,0,1)/ -1/ ! l=9 #=0 - - DATA JKVANT(9,0,1,1)/ 17/ + DATA JKVANT(9,0,1,1)/ 17/ ! data SENIOR(9,0,1,1) / 1/ - DATA SENIOR(9,0,1,1)/ -1/ + DATA SENIOR(9,0,1,1)/ -1/ ! l=9 #=1 - - DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ ! data (SENIOR(9,0,2,i),i=1,9) / 0, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(9,0,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(9,0,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=9 #=2 - - DATA JKVANT(9,1,0,1)/ 0/ + DATA JKVANT(9,1,0,1)/ 0/ ! data SENIOR(9,1,0,1) / 0/ - DATA SENIOR(9,1,0,1)/ -1/ + DATA SENIOR(9,1,0,1)/ -1/ ! l=9 #=0 + - DATA JKVANT(9,1,1,1)/ 19/ + DATA JKVANT(9,1,1,1)/ 19/ ! data SENIOR(9,1,1,1) / 1/ - DATA SENIOR(9,1,1,1)/ -1/ + DATA SENIOR(9,1,1,1)/ -1/ ! l=9 #=1 + - DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ ! data (SENIOR(9,1,2,i),i=1,10) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(9,1,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(9,1,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=9 #=2 + - DATA JKVANT(10,0,0,1)/ 0/ + DATA JKVANT(10,0,0,1)/ 0/ ! data SENIOR(10,0,0,1) / 0/ - DATA SENIOR(10,0,0,1)/ -1/ + DATA SENIOR(10,0,0,1)/ -1/ ! l=10 #=0 - - DATA JKVANT(10,0,1,1)/ 19/ + DATA JKVANT(10,0,1,1)/ 19/ ! data SENIOR(10,0,1,1) / 1/ - DATA SENIOR(10,0,1,1)/ -1/ + DATA SENIOR(10,0,1,1)/ -1/ ! l=10 #=1 - - DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ ! data (SENIOR(10,0,2,i),i=1,10) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(10,0,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(10,0,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=10 #=2 - - DATA JKVANT(10,1,0,1)/ 0/ + DATA JKVANT(10,1,0,1)/ 0/ ! data SENIOR(10,1,0,1) / 0/ - DATA SENIOR(10,1,0,1)/ -1/ + DATA SENIOR(10,1,0,1)/ -1/ ! l=10 #=0 + - DATA JKVANT(10,1,1,1)/ 21/ + DATA JKVANT(10,1,1,1)/ 21/ ! data SENIOR(10,1,1,1) / 1/ - DATA SENIOR(10,1,1,1)/ -1/ + DATA SENIOR(10,1,1,1)/ -1/ ! l=10 #=1 + - DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ + DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ ! data (SENIOR(10,1,2,i),i=1,11) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, ! : 2/ DATA (SENIOR(10,1,2,I),I=1,11)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & - -1/ + -1/ ! l=10 #=2 + - IF (FIRST) THEN - FIL = FIL_1 - ELSE - FIL = FIL_2 - ENDIF - ANTKO = 1 - POS = 0 - DO I = 1, 110 - N = POSN(I) - L = POSL(I) + IF (FIRST) THEN + FIL = FIL_1 + ELSE + FIL = FIL_2 + ENDIF + ANTKO = 1 + POS = 0 + DO I = 1, 110 + N = POSN(I) + L = POSL(I) !Jacek mailed the fix 98-10-29 - IF (N < 10) THEN - DO K = 0, MIN(L,1) + IF (N < 10) THEN + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ELSE - DO K = 0, MIN(L,1) + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ELSE + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - N1 = MOD(N,10) - N10 = N/10 - RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ENDIF - END DO - - IF (POS == 0) RETURN - DO I1 = 1, ANTKO(1) - DO I2 = 1, ANTKO(2) - DO I3 = 1, ANTKO(3) - DO I4 = 1, ANTKO(4) - DO I5 = 1, ANTKO(5) - DO I6 = 1, ANTKO(6) - DO I7 = 1, ANTKO(7) - DO I8 = 1, ANTKO(8) - DO I9 = 1, ANTKO(9) - DO I10 = 1, ANTKO(10) - DO I11 = 1, ANTKO(11) - DO I12 = 1, ANTKO(12) - DO I13 = 1, ANTKO(13) - DO I14 = 1, ANTKO(14) - DO I15 = 1, ANTKO(15) - DO I16 = 1, ANTKO(16) - DO I17 = 1, ANTKO(17) - DO I18 = 1, ANTKO(18) - DO I19 = 1, ANTKO(19) - DO I20 = 1, ANTKO(20) - - J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) - S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) - IF (POS == 1) THEN - IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:9) - WRITE (FIL, 999) RAD2(1:9) - WRITE (FIL, 999) RAD3(1:11) - CF = CF + 1 - ENDIF - ELSE - - DO RESJ = MINJ, MAXJ, 2 - JK(POS-1) = RESJ - J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) - S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) - IF (POS == 2) THEN + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + N1 = MOD(N,10) + N10 = N/10 + RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ENDIF + END DO + + IF (POS == 0) RETURN + DO I1 = 1, ANTKO(1) + DO I2 = 1, ANTKO(2) + DO I3 = 1, ANTKO(3) + DO I4 = 1, ANTKO(4) + DO I5 = 1, ANTKO(5) + DO I6 = 1, ANTKO(6) + DO I7 = 1, ANTKO(7) + DO I8 = 1, ANTKO(8) + DO I9 = 1, ANTKO(9) + DO I10 = 1, ANTKO(10) + DO I11 = 1, ANTKO(11) + DO I12 = 1, ANTKO(12) + DO I13 = 1, ANTKO(13) + DO I14 = 1, ANTKO(14) + DO I15 = 1, ANTKO(15) + DO I16 = 1, ANTKO(16) + DO I17 = 1, ANTKO(17) + DO I18 = 1, ANTKO(18) + DO I19 = 1, ANTKO(19) + DO I20 = 1, ANTKO(20) + + J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) + S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) + IF (POS == 1) THEN + IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:9) + WRITE (FIL, 999) RAD2(1:9) + WRITE (FIL, 999) RAD3(1:11) + CF = CF + 1 + ENDIF + ELSE + + DO RESJ = MINJ, MAXJ, 2 + JK(POS-1) = RESJ + J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) + S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) + IF (POS == 2) THEN IF (RESJ>=ABS(J(1)-J(2)) .AND. RESJ<=J(1)+J& - (2)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:18) - WRITE (FIL, 999) RAD2(1:18) - WRITE (FIL, 999) RAD3(1:20) - CF = CF + 1 - ENDIF - ELSE - - J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) - S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) - DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 - JK(1) = JK1 - IF (POS == 3) THEN + (2)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:18) + WRITE (FIL, 999) RAD2(1:18) + WRITE (FIL, 999) RAD3(1:20) + CF = CF + 1 + ENDIF + ELSE + + J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) + S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) + DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 + JK(1) = JK1 + IF (POS == 3) THEN IF (RESJ>=ABS(JK1 - J(3)) .AND. RESJ<=JK1+J& - (3)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:27) - WRITE (FIL, 999) RAD2(1:27) - WRITE (FIL, 999) RAD3(1:29) - CF = CF + 1 - ENDIF - ELSE - - J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) - S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) - DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 - JK(2) = JK2 - IF (POS == 4) THEN + (3)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:27) + WRITE (FIL, 999) RAD2(1:27) + WRITE (FIL, 999) RAD3(1:29) + CF = CF + 1 + ENDIF + ELSE + + J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) + S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) + DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 + JK(2) = JK2 + IF (POS == 4) THEN IF (RESJ>=ABS(JK2 - J(4)) .AND. RESJ<=JK2+J& - (4)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:36) - WRITE (FIL, 999) RAD2(1:36) - WRITE (FIL, 999) RAD3(1:38) - CF = CF + 1 - ENDIF - ELSE - - J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) - S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) - DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 - JK(3) = JK3 - IF (POS == 5) THEN + (4)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:36) + WRITE (FIL, 999) RAD2(1:36) + WRITE (FIL, 999) RAD3(1:38) + CF = CF + 1 + ENDIF + ELSE + + J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) + S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) + DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 + JK(3) = JK3 + IF (POS == 5) THEN IF (RESJ>=ABS(JK3 - J(5)) .AND. RESJ<=JK3+J& - (5)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:45) - WRITE (FIL, 999) RAD2(1:45) - WRITE (FIL, 999) RAD3(1:47) - CF = CF + 1 - ENDIF - ELSE - - J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) - S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) - DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 - JK(4) = JK4 - IF (POS == 6) THEN + (5)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:45) + WRITE (FIL, 999) RAD2(1:45) + WRITE (FIL, 999) RAD3(1:47) + CF = CF + 1 + ENDIF + ELSE + + J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) + S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) + DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 + JK(4) = JK4 + IF (POS == 6) THEN IF (RESJ>=ABS(JK4 - J(6)) .AND. RESJ<=JK4+J& - (6)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:54) - WRITE (FIL, 999) RAD2(1:54) - WRITE (FIL, 999) RAD3(1:56) - CF = CF + 1 - ENDIF - ELSE - - J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) - S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) - DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 - JK(5) = JK5 - IF (POS == 7) THEN + (6)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:54) + WRITE (FIL, 999) RAD2(1:54) + WRITE (FIL, 999) RAD3(1:56) + CF = CF + 1 + ENDIF + ELSE + + J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) + S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) + DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 + JK(5) = JK5 + IF (POS == 7) THEN IF (RESJ>=ABS(JK5 - J(7)) .AND. RESJ<=JK5+J& - (7)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:63) - WRITE (FIL, 999) RAD2(1:63) - WRITE (FIL, 999) RAD3(1:65) - CF = CF + 1 - ENDIF - ELSE - - J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) - S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) - DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 - JK(6) = JK6 - IF (POS == 8) THEN + (7)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:63) + WRITE (FIL, 999) RAD2(1:63) + WRITE (FIL, 999) RAD3(1:65) + CF = CF + 1 + ENDIF + ELSE + + J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) + S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) + DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 + JK(6) = JK6 + IF (POS == 8) THEN IF (RESJ>=ABS(JK6 - J(8)) .AND. RESJ<=JK6+J& - (8)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:72) - WRITE (FIL, 999) RAD2(1:72) - WRITE (FIL, 999) RAD3(1:74) - CF = CF + 1 - ENDIF - ELSE - - J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) - S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) - DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 - JK(7) = JK7 - IF (POS == 9) THEN + (8)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:72) + WRITE (FIL, 999) RAD2(1:72) + WRITE (FIL, 999) RAD3(1:74) + CF = CF + 1 + ENDIF + ELSE + + J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) + S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) + DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 + JK(7) = JK7 + IF (POS == 9) THEN IF (RESJ>=ABS(JK7 - J(9)) .AND. RESJ<=JK7+J& - (9)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:81) - WRITE (FIL, 999) RAD2(1:81) - WRITE (FIL, 999) RAD3(1:83) - CF = CF + 1 - ENDIF - ELSE - + (9)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:81) + WRITE (FIL, 999) RAD2(1:81) + WRITE (FIL, 999) RAD3(1:83) + CF = CF + 1 + ENDIF + ELSE + J(10) = JKVANT(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) + ,I10) S(10) = SENIOR(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) - DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 - JK(8) = JK8 - IF (POS == 10) THEN + ,I10) + DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 + JK(8) = JK8 + IF (POS == 10) THEN IF (RESJ>=ABS(JK8 - J(10)) .AND. RESJ<=JK8+& - J(10)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:90) - WRITE (FIL, 999) RAD2(1:90) - WRITE (FIL, 999) RAD3(1:92) - CF = CF + 1 - ENDIF - ELSE - + J(10)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:90) + WRITE (FIL, 999) RAD2(1:90) + WRITE (FIL, 999) RAD3(1:92) + CF = CF + 1 + ENDIF + ELSE + J(11) = JKVANT(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) + ,I11) S(11) = SENIOR(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) - DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 - JK(9) = JK9 - IF (POS == 11) THEN + ,I11) + DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 + JK(9) = JK9 + IF (POS == 11) THEN IF (RESJ>=ABS(JK9 - J(11)) .AND. RESJ<=JK9+& - J(11)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:99) - WRITE (FIL, 999) RAD2(1:99) - WRITE (FIL, 999) RAD3(1:101) - CF = CF + 1 - ENDIF - ELSE - + J(11)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:99) + WRITE (FIL, 999) RAD2(1:99) + WRITE (FIL, 999) RAD3(1:101) + CF = CF + 1 + ENDIF + ELSE + J(12) = JKVANT(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) + ,I12) S(12) = SENIOR(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) - DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 - JK(10) = JK10 - IF (POS == 12) THEN + ,I12) + DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 + JK(10) = JK10 + IF (POS == 12) THEN IF (RESJ>=ABS(JK10 - J(12)) .AND. RESJ<=& - JK10+J(12)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:108) - WRITE (FIL, 999) RAD2(1:108) - WRITE (FIL, 999) RAD3(1:110) - CF = CF + 1 - ENDIF - ELSE - + JK10+J(12)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:108) + WRITE (FIL, 999) RAD2(1:108) + WRITE (FIL, 999) RAD3(1:110) + CF = CF + 1 + ENDIF + ELSE + J(13) = JKVANT(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) S(13) = SENIOR(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) DO JK11 = ABS(JK10 - J(12)), JK10 + J(12), & - 2 - JK(11) = JK11 - IF (POS == 13) THEN + 2 + JK(11) = JK11 + IF (POS == 13) THEN IF (RESJ>=ABS(JK11 - J(13)) .AND. RESJ<=& - JK11+J(13)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:117) - WRITE (FIL, 999) RAD2(1:117) - WRITE (FIL, 999) RAD3(1:119) - CF = CF + 1 - ENDIF - ELSE - + JK11+J(13)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:117) + WRITE (FIL, 999) RAD2(1:117) + WRITE (FIL, 999) RAD3(1:119) + CF = CF + 1 + ENDIF + ELSE + J(14) = JKVANT(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) S(14) = SENIOR(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) DO JK12 = ABS(JK11 - J(13)), JK11 + J(13), & - 2 - JK(12) = JK12 - IF (POS == 14) THEN + 2 + JK(12) = JK12 + IF (POS == 14) THEN IF (RESJ>=ABS(JK12 - J(14)) .AND. RESJ<=& - JK12+J(14)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:126) - WRITE (FIL, 999) RAD2(1:126) - WRITE (FIL, 999) RAD3(1:128) - CF = CF + 1 - ENDIF - ELSE - + JK12+J(14)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:126) + WRITE (FIL, 999) RAD2(1:126) + WRITE (FIL, 999) RAD3(1:128) + CF = CF + 1 + ENDIF + ELSE + J(15) = JKVANT(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) S(15) = SENIOR(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) DO JK13 = ABS(JK12 - J(14)), JK12 + J(14), & - 2 - JK(13) = JK13 - IF (POS == 15) THEN + 2 + JK(13) = JK13 + IF (POS == 15) THEN IF (RESJ>=ABS(JK13 - J(15)) .AND. RESJ<=& - JK13+J(15)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:135) - WRITE (FIL, 999) RAD2(1:135) - WRITE (FIL, 999) RAD3(1:137) - CF = CF + 1 - ENDIF - ELSE - + JK13+J(15)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:135) + WRITE (FIL, 999) RAD2(1:135) + WRITE (FIL, 999) RAD3(1:137) + CF = CF + 1 + ENDIF + ELSE + J(16) = JKVANT(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) S(16) = SENIOR(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) DO JK14 = ABS(JK13 - J(15)), JK13 + J(15), & - 2 - JK(14) = JK14 - IF (POS == 16) THEN + 2 + JK(14) = JK14 + IF (POS == 16) THEN IF (RESJ>=ABS(JK14 - J(16)) .AND. RESJ<=& - JK14+J(16)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:144) - WRITE (FIL, 999) RAD2(1:144) - WRITE (FIL, 999) RAD3(1:146) - CF = CF + 1 - ENDIF - ELSE - + JK14+J(16)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:144) + WRITE (FIL, 999) RAD2(1:144) + WRITE (FIL, 999) RAD3(1:146) + CF = CF + 1 + ENDIF + ELSE + J(17) = JKVANT(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) S(17) = SENIOR(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) DO JK15 = ABS(JK14 - J(16)), JK14 + J(16), & - 2 - JK(15) = JK15 - IF (POS == 17) THEN + 2 + JK(15) = JK15 + IF (POS == 17) THEN IF (RESJ>=ABS(JK15 - J(17)) .AND. RESJ<=& - JK15+J(17)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:153) - WRITE (FIL, 999) RAD2(1:153) - WRITE (FIL, 999) RAD3(1:155) - CF = CF + 1 - ENDIF - ELSE - + JK15+J(17)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:153) + WRITE (FIL, 999) RAD2(1:153) + WRITE (FIL, 999) RAD3(1:155) + CF = CF + 1 + ENDIF + ELSE + J(18) = JKVANT(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) S(18) = SENIOR(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) DO JK16 = ABS(JK15 - J(17)), JK15 + J(17), & - 2 - JK(16) = JK16 - IF (POS == 18) THEN + 2 + JK(16) = JK16 + IF (POS == 18) THEN IF (RESJ>=ABS(JK16 - J(18)) .AND. RESJ<=& - JK16+J(18)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:162) - WRITE (FIL, 999) RAD2(1:162) - WRITE (FIL, 999) RAD3(1:164) - CF = CF + 1 - ENDIF - ELSE - + JK16+J(18)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:162) + WRITE (FIL, 999) RAD2(1:162) + WRITE (FIL, 999) RAD3(1:164) + CF = CF + 1 + ENDIF + ELSE + J(19) = JKVANT(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) S(19) = SENIOR(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) DO JK17 = ABS(JK16 - J(18)), JK16 + J(18), & - 2 - JK(17) = JK17 - IF (POS == 19) THEN + 2 + JK(17) = JK17 + IF (POS == 19) THEN IF (RESJ>=ABS(JK17 - J(19)) .AND. RESJ<=& - JK17+J(19)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:171) - WRITE (FIL, 999) RAD2(1:171) - WRITE (FIL, 999) RAD3(1:173) - CF = CF + 1 - ENDIF - ELSE - + JK17+J(19)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:171) + WRITE (FIL, 999) RAD2(1:171) + WRITE (FIL, 999) RAD3(1:173) + CF = CF + 1 + ENDIF + ELSE + J(20) = JKVANT(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) S(20) = SENIOR(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) DO JK18 = ABS(JK17 - J(19)), JK17 + J(19), & - 2 + 2 IF (RESJJK18+J& - (20)) CYCLE - JK(18) = JK18 - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:180) - WRITE (FIL, 999) RAD2(1:180) - WRITE (FIL, 999) RAD3(1:182) - CF = CF + 1 - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - 999 FORMAT(2A) - RETURN - END SUBROUTINE GEN + (20)) CYCLE + JK(18) = JK18 + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:180) + WRITE (FIL, 999) RAD2(1:180) + WRITE (FIL, 999) RAD3(1:182) + CF = CF + 1 + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + 999 FORMAT(2A) + RETURN + END SUBROUTINE GEN diff --git a/src/appl/jjgen90/jjgen15.f90 b/src/appl/jjgen90/jjgen15.f90 index 458c007f0..3a3be1b63 100644 --- a/src/appl/jjgen90/jjgen15.f90 +++ b/src/appl/jjgen90/jjgen15.f90 @@ -10,98 +10,98 @@ ! ! ------------------------------------------------------------------ ! - program jjgen15 -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + program jjgen15 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reffa_I - use adder_I - use matcin_I - use blandc_I - use matain_I - use fivelines_I - use blanda_I - use matbin_I - use merge_I + use reffa_I + use adder_I + use matcin_I + use blandc_I + use matain_I + use fivelines_I + use blanda_I + use matbin_I + use merge_I implicit none !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: org - integer :: varmax, skal, anel, par - integer , dimension(15,0:10) :: low - integer , dimension(110) :: posn, posl - integer :: nmax - integer , dimension(15) :: lim - integer :: minj, maxj, cfmax - logical , dimension(15,0:10) :: lock, closed - logical :: slut - logical , dimension(15,0:10) :: med, dubbel - logical :: advexp, second - character :: x + integer , dimension(15,0:10) :: org + integer :: varmax, skal, anel, par + integer , dimension(15,0:10) :: low + integer , dimension(110) :: posn, posl + integer :: nmax + integer , dimension(15) :: lim + integer :: minj, maxj, cfmax + logical , dimension(15,0:10) :: lock, closed + logical :: slut + logical , dimension(15,0:10) :: med, dubbel + logical :: advexp, second + character :: x !----------------------------------------------- - open(unit=logfil, file='clist.log', status='unknown', position='asis') - write (*, *) 'Version 2' - write (*, 200) ' * : new list' - write (*, 200) ' a : add to existing list' - write (*, 200) ' e : expand existing list' - write (*, 200) ' q : quit' - read (*, 100) x - write (logfil, 200) ' Option : ', x - call reffa (posn, posl) - advexp = .FALSE. - if (x=='a' .or. x=='A') then - call adder (closed, med, slut, anel, par, .FALSE.) - if (slut) then - write (*, 200) - write (*, 200) 'The clist.inp-file is not readable! ' - stop - endif - write (logfil, 200) ' New reference set.' - second = .TRUE. - else if (x=='e' .or. x=='E') then - advexp = .TRUE. - call adder (closed, med, slut, anel, par, .TRUE.) - if (slut) then - write (*, 200) - write (*, 200) 'The clist.inp-file is not readable! ' - stop - endif - write (logfil, 200) ' File as reference sets.' - call matcin (lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim) + open(unit=logfil, file='clist.log', status='unknown', position='asis') + write (*, *) 'Version 2' + write (*, 200) ' * : new list' + write (*, 200) ' a : add to existing list' + write (*, 200) ' e : expand existing list' + write (*, 200) ' q : quit' + read (*, 100) x + write (logfil, 200) ' Option : ', x + call reffa (posn, posl) + advexp = .FALSE. + if (x=='a' .or. x=='A') then + call adder (closed, med, slut, anel, par, .FALSE.) + if (slut) then + write (*, 200) + write (*, 200) 'The clist.inp-file is not readable! ' + stop + endif + write (logfil, 200) ' New reference set.' + second = .TRUE. + else if (x=='e' .or. x=='E') then + advexp = .TRUE. + call adder (closed, med, slut, anel, par, .TRUE.) + if (slut) then + write (*, 200) + write (*, 200) 'The clist.inp-file is not readable! ' + stop + endif + write (logfil, 200) ' File as reference sets.' + call matcin (lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim) call blandc (varmax, cfmax, lock, med, minj, maxj, nmax, posn, posl, & - lim) - second = .FALSE. - else + lim) + second = .FALSE. + else call matain (org, lock, closed, varmax, skal, nmax, anel, par, low, & - minj, maxj, lim, dubbel) - call fivelines (org, lock, closed, .TRUE., posn, posl) + minj, maxj, lim, dubbel) + call fivelines (org, lock, closed, .TRUE., posn, posl) call blanda (org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, .TRUE.) - second = .FALSE. - endif + posl, lim, dubbel, .TRUE.) + second = .FALSE. + endif if (.not.advexp) call matbin (org, lock, closed, varmax, skal, second, & - anel, par, low, nmax, lim, dubbel, minj, maxj) - if (second) then - call fivelines (org, lock, closed, .FALSE., posn, posl) + anel, par, low, nmax, lim, dubbel, minj, maxj) + if (second) then + call fivelines (org, lock, closed, .FALSE., posn, posl) call blanda (org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, .FALSE.) - call merge (.FALSE., posn, posl) - write (*, 200) 'The merged file is called clist.out.' - else - call merge (.TRUE., posn, posl) - write (*, 200) 'The generated file is called clist.out.' - endif - stop - 100 format(a) - 200 format(' ',10a) - 300 format(' ',a,i2,a) - 400 format(' ',a,i3,a) - stop - end program jjgen15 + posl, lim, dubbel, .FALSE.) + call merge (.FALSE., posn, posl) + write (*, 200) 'The merged file is called clist.out.' + else + call merge (.TRUE., posn, posl) + write (*, 200) 'The generated file is called clist.out.' + endif + stop + 100 format(a) + 200 format(' ',10a) + 300 format(' ',a,i2,a) + 400 format(' ',a,i3,a) + stop + end program jjgen15 diff --git a/src/appl/jjgen90/jjgen15.or b/src/appl/jjgen90/jjgen15.or index 202151671..3f2f268a9 100644 --- a/src/appl/jjgen90/jjgen15.or +++ b/src/appl/jjgen90/jjgen15.or @@ -1,10 +1,10 @@ if (.NOT.advexp) : call Matbin(org,lock,closed,varmax,skal,second,anel, - : par,low,nmax,lim,dubbel,minJ,maxJ) + : par,low,nmax,lim,dubbel,minJ,maxJ) if (second) then call Fivelines(org,lock,closed,.FALSE.,posn,posl) call Blanda(org,varmax,lock,minJ,maxJ,skal,nmax,low, - : posn,posl,lim,dubbel,.FALSE.) + : posn,posl,lim,dubbel,.FALSE.) call Merge(.FALSE.,posn,posl) write(*,200) 'The merged file is called clist.out.' else diff --git a/src/appl/jjgen90/jjgen15b.f90 b/src/appl/jjgen90/jjgen15b.f90 index 774e67030..cc83d7820 100644 --- a/src/appl/jjgen90/jjgen15b.f90 +++ b/src/appl/jjgen90/jjgen15b.f90 @@ -10,123 +10,123 @@ ! ! ------------------------------------------------------------------ ! - program jjgen15 -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + program jjgen15 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reffa_I - use adder_I - use matcin_I - use blandc_I - use matain_I - use fivelines_I - use blanda_I - use merge_I - use open79_I - use matbin_I - use copy7t9_I + use reffa_I + use adder_I + use matcin_I + use blandc_I + use matain_I + use fivelines_I + use blanda_I + use merge_I + use open79_I + use matbin_I + use copy7t9_I implicit none !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: org - integer :: varmax, skal, anel, par - integer , dimension(15,0:10) :: low - integer , dimension(110) :: posn, posl - integer :: nmax - integer , dimension(15) :: lim - integer :: minj, maxj, cfmax, ii - logical , dimension(15,0:10) :: lock, closed - logical :: slut - logical , dimension(15,0:10) :: med, dubbel - logical :: advexp, second - character :: x + integer , dimension(15,0:10) :: org + integer :: varmax, skal, anel, par + integer , dimension(15,0:10) :: low + integer , dimension(110) :: posn, posl + integer :: nmax + integer , dimension(15) :: lim + integer :: minj, maxj, cfmax, ii + logical , dimension(15,0:10) :: lock, closed + logical :: slut + logical , dimension(15,0:10) :: med, dubbel + logical :: advexp, second + character :: x !----------------------------------------------- - open(unit=logfil, file='clist.log', status='unknown', position='asis') + open(unit=logfil, file='clist.log', status='unknown', position='asis') write(*,*) write(*,*) 'JJGEN' write(*,*) 'This program generates a list of CSFs' - write(*,*) + write(*,*) write(*,*) 'Output files: clist.out, clist.log' write(*,*) 'Note that clist.out is not in block form. To convert' write(*,*) 'to block form copy clist.out to rcsf.inp and run' write(*,*) 'rcsfblock' - write(*,*) - write (*, 200) ' * : new list' - write (*, 200) ' a : add to existing list' - write (*, 200) ' e : expand existing list' - write (*, 200) ' q : quit' - read (*, 100) x - write (logfil, 200) ' Option : ', x - call reffa (posn, posl) - advexp = .FALSE. - if (x=='a' .or. x=='A') then - call adder (closed, med, slut, anel, par, .FALSE.) - if (slut) then - write (*, 200) - write (*, 200) 'The clist.inp-file is not readable! ' - stop - endif - write (logfil, 200) ' New reference set.' - second = .TRUE. - else if (x=='e' .or. x=='E') then - advexp = .TRUE. - call adder (closed, med, slut, anel, par, .TRUE.) - if (slut) then - write (*, 200) - write (*, 200) 'The clist.inp-file is not readable! ' - stop - endif - write (logfil, 200) ' File as reference sets.' - call matcin (lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim) + write(*,*) + write (*, 200) ' * : new list' + write (*, 200) ' a : add to existing list' + write (*, 200) ' e : expand existing list' + write (*, 200) ' q : quit' + read (*, 100) x + write (logfil, 200) ' Option : ', x + call reffa (posn, posl) + advexp = .FALSE. + if (x=='a' .or. x=='A') then + call adder (closed, med, slut, anel, par, .FALSE.) + if (slut) then + write (*, 200) + write (*, 200) 'The clist.inp-file is not readable! ' + stop + endif + write (logfil, 200) ' New reference set.' + second = .TRUE. + else if (x=='e' .or. x=='E') then + advexp = .TRUE. + call adder (closed, med, slut, anel, par, .TRUE.) + if (slut) then + write (*, 200) + write (*, 200) 'The clist.inp-file is not readable! ' + stop + endif + write (logfil, 200) ' File as reference sets.' + call matcin (lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim) call blandc (varmax, cfmax, lock, med, minj, maxj, nmax, posn, posl, & - lim) - second = .FALSE. - else + lim) + second = .FALSE. + else call matain (org, lock, closed, varmax, skal, nmax, anel, par, low, & - minj, maxj, lim, dubbel) - call fivelines (org, lock, closed, .TRUE., posn, posl) + minj, maxj, lim, dubbel) + call fivelines (org, lock, closed, .TRUE., posn, posl) call blanda (org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, .TRUE.) - second = .FALSE. - endif - ii = 0 - if (.not.second) then - call merge (.TRUE., posn, posl, ii) - if (advexp) ii = ii + 1 - call open79 (ii) - endif - - do while(.TRUE.) + posl, lim, dubbel, .TRUE.) + second = .FALSE. + endif + ii = 0 + if (.not.second) then + call merge (.TRUE., posn, posl, ii) + if (advexp) ii = ii + 1 + call open79 (ii) + endif + + do while(.TRUE.) call matbin (org, lock, closed, varmax, skal, second, anel, par, low, & - nmax, lim, dubbel, minj, maxj) - if (.not.second) exit - call fivelines (org, lock, closed, .FALSE., posn, posl) + nmax, lim, dubbel, minj, maxj) + if (.not.second) exit + call fivelines (org, lock, closed, .FALSE., posn, posl) call blanda (org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, .FALSE.) - call merge (.FALSE., posn, posl, ii) - ii = ii + 1 - call open79 (ii) - second = .FALSE. - end do - write (*, 200) 'The merged file is called clist.out.' - if (mod(ii,2)==0 .and. ii/=0) call copy7t9 - if (mod(ii,2) /= 0) then - open(unit=93, file='fil1.dat', status='unknown', position='asis') - close(unit=93, status='delete') - endif - if (ii == 0) close(unit=7, status='delete') - stop - 100 format(a) - 200 format(' ',10a) - 300 format(' ',a,i2,a) - 400 format(' ',a,i3,a) - stop - end program jjgen15 + posl, lim, dubbel, .FALSE.) + call merge (.FALSE., posn, posl, ii) + ii = ii + 1 + call open79 (ii) + second = .FALSE. + end do + write (*, 200) 'The merged file is called clist.out.' + if (mod(ii,2)==0 .and. ii/=0) call copy7t9 + if (mod(ii,2) /= 0) then + open(unit=93, file='fil1.dat', status='unknown', position='asis') + close(unit=93, status='delete') + endif + if (ii == 0) close(unit=7, status='delete') + stop + 100 format(a) + 200 format(' ',10a) + 300 format(' ',a,i2,a) + 400 format(' ',a,i3,a) + stop + end program jjgen15 diff --git a/src/appl/jjgen90/kopp1.f90 b/src/appl/jjgen90/kopp1.f90 index 37122100c..3e99e33f7 100644 --- a/src/appl/jjgen90/kopp1.f90 +++ b/src/appl/jjgen90/kopp1.f90 @@ -1,51 +1,51 @@ ! last edited July 30, 1996 - subroutine kopp1(pos, rad2, j, s, antko) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine kopp1(pos, rad2, j, s, antko) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pos - character , intent(out) :: rad2*200 - integer , intent(in) :: j(20) - integer , intent(in) :: s(20) - integer , intent(in) :: antko(20) + integer , intent(in) :: pos + character , intent(out) :: rad2*200 + integer , intent(in) :: j(20) + integer , intent(in) :: s(20) + integer , intent(in) :: antko(20) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, k, tal + integer :: i, k, tal !----------------------------------------------- - do i = 1, 200 - rad2(i:i) = ' ' - end do - do i = 1, pos - k = 9*i - if (j(i) == 2*(j(i)/2)) then - if (.not.(j(i)==0 .and. antko(i)==1)) then - if (s(i) /= (-1)) then - rad2(k-4:k-4) = ';' - rad2(k-5:k-5) = char(48 + s(i)) - endif - tal = j(i)/20 + do i = 1, 200 + rad2(i:i) = ' ' + end do + do i = 1, pos + k = 9*i + if (j(i) == 2*(j(i)/2)) then + if (.not.(j(i)==0 .and. antko(i)==1)) then + if (s(i) /= (-1)) then + rad2(k-4:k-4) = ';' + rad2(k-5:k-5) = char(48 + s(i)) + endif + tal = j(i)/20 if (tal /= 0) then -!GG rad2(k:k) = char(48 + tal) +!GG rad2(k:k) = char(48 + tal) rad2(k-1:k-1) = char(48+tal) end if - tal = j(i)/2 - tal*10 - rad2(k:k) = char(48 + tal) - endif - else - if (s(i) /= (-1)) then - rad2(k-4:k-4) = ';' - rad2(k-5:k-5) = char(48 + s(i)) - endif - tal = j(i)/10 - if (tal /= 0) rad2(k-3:k-3) = char(48 + tal) - tal = j(i) - tal*10 - rad2(k-2:k-2) = char(48 + tal) - rad2(k-1:k) = '/2' - endif - end do - return - end subroutine kopp1 + tal = j(i)/2 - tal*10 + rad2(k:k) = char(48 + tal) + endif + else + if (s(i) /= (-1)) then + rad2(k-4:k-4) = ';' + rad2(k-5:k-5) = char(48 + s(i)) + endif + tal = j(i)/10 + if (tal /= 0) rad2(k-3:k-3) = char(48 + tal) + tal = j(i) - tal*10 + rad2(k-2:k-2) = char(48 + tal) + rad2(k-1:k) = '/2' + endif + end do + return + end subroutine kopp1 diff --git a/src/appl/jjgen90/kopp1_I.f90 b/src/appl/jjgen90/kopp1_I.f90 index 375667777..f96669def 100644 --- a/src/appl/jjgen90/kopp1_I.f90 +++ b/src/appl/jjgen90/kopp1_I.f90 @@ -1,12 +1,12 @@ - MODULE kopp1_I + MODULE kopp1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE kopp1 (POS, RAD2, J, S, ANTKO) - integer, INTENT(IN) :: POS - character (LEN = 200), INTENT(OUT) :: RAD2 - integer, DIMENSION(20), INTENT(IN) :: J - integer, DIMENSION(20), INTENT(IN) :: S - integer, DIMENSION(20), INTENT(IN) :: ANTKO - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE kopp1 (POS, RAD2, J, S, ANTKO) + integer, INTENT(IN) :: POS + character (LEN = 200), INTENT(OUT) :: RAD2 + integer, DIMENSION(20), INTENT(IN) :: J + integer, DIMENSION(20), INTENT(IN) :: S + integer, DIMENSION(20), INTENT(IN) :: ANTKO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/kopp2.f90 b/src/appl/jjgen90/kopp2.f90 index bd362dcdc..a22fab4fc 100644 --- a/src/appl/jjgen90/kopp2.f90 +++ b/src/appl/jjgen90/kopp2.f90 @@ -1,70 +1,70 @@ ! last edited July 30, 1996 - subroutine kopp2(pos, rad3, j, jprim, par, antko) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine kopp2(pos, rad3, j, jprim, par, antko) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pos - integer , intent(in) :: par - character , intent(out) :: rad3*200 - integer , intent(in) :: j(20) - integer , intent(in) :: jprim(20) - integer , intent(in) :: antko(20) + integer , intent(in) :: pos + integer , intent(in) :: par + character , intent(out) :: rad3*200 + integer , intent(in) :: j(20) + integer , intent(in) :: jprim(20) + integer , intent(in) :: antko(20) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, k, tal - logical :: first + integer :: i, k, tal + logical :: first !----------------------------------------------- - - first = .TRUE. - do i = 1, 200 - rad3(i:i) = ' ' - end do - i = max(1,pos - 1) - k = 9*pos - 2 - if (j(i) == 2*(j(i)/2)) then - tal = j(i)/20 - if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) - tal = j(i)/2 - tal*10 - rad3(k+3:k+3) = char(48 + tal) - else - tal = j(i)/10 - if (tal /= 0) rad3(k:k) = char(48 + tal) - tal = j(i) - tal*10 - rad3(k+1:k+1) = char(48 + tal) - rad3(k+2:k+3) = '/2' - endif - if (par == 0) then - rad3(k+4:k+4) = '+' - else - rad3(k+4:k+4) = '-' - endif - if (pos > 2) then + + first = .TRUE. + do i = 1, 200 + rad3(i:i) = ' ' + end do + i = max(1,pos - 1) + k = 9*pos - 2 + if (j(i) == 2*(j(i)/2)) then + tal = j(i)/20 + if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) + tal = j(i)/2 - tal*10 + rad3(k+3:k+3) = char(48 + tal) + else + tal = j(i)/10 + if (tal /= 0) rad3(k:k) = char(48 + tal) + tal = j(i) - tal*10 + rad3(k+1:k+1) = char(48 + tal) + rad3(k+2:k+3) = '/2' + endif + if (par == 0) then + rad3(k+4:k+4) = '+' + else + rad3(k+4:k+4) = '-' + endif + if (pos > 2) then if (jprim(1)/=0 .or. .not.(jprim(1)==0 .and. antko(1)==1)) first = & - .FALSE. - do i = 1, pos - 2 + .FALSE. + do i = 1, pos - 2 if (first .and. (jprim(i+1)/=0 .or. jprim(i+1)==0 .and. antko(i+1)& - /=1)) then - first = .FALSE. - else if (.not.first .and. jprim(i+1)/=0) then - k = 9*(i + 1) - if (j(i) == 2*(j(i)/2)) then - tal = j(i)/20 - if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) - tal = j(i)/2 - tal*10 - rad3(k+3:k+3) = char(48 + tal) - else - tal = j(i)/10 - if (tal /= 0) rad3(k:k) = char(48 + tal) - tal = j(i) - tal*10 - rad3(k+1:k+1) = char(48 + tal) - rad3(k+2:k+3) = '/2' - endif - endif - end do - endif - return - end subroutine kopp2 + /=1)) then + first = .FALSE. + else if (.not.first .and. jprim(i+1)/=0) then + k = 9*(i + 1) + if (j(i) == 2*(j(i)/2)) then + tal = j(i)/20 + if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) + tal = j(i)/2 - tal*10 + rad3(k+3:k+3) = char(48 + tal) + else + tal = j(i)/10 + if (tal /= 0) rad3(k:k) = char(48 + tal) + tal = j(i) - tal*10 + rad3(k+1:k+1) = char(48 + tal) + rad3(k+2:k+3) = '/2' + endif + endif + end do + endif + return + end subroutine kopp2 diff --git a/src/appl/jjgen90/kopp2_I.f90 b/src/appl/jjgen90/kopp2_I.f90 index f784b8f3c..8de3b034d 100644 --- a/src/appl/jjgen90/kopp2_I.f90 +++ b/src/appl/jjgen90/kopp2_I.f90 @@ -1,13 +1,13 @@ - MODULE kopp2_I + MODULE kopp2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE kopp2 (POS, RAD3, J, JPRIM, PAR, ANTKO) - integer, INTENT(IN) :: POS - character (LEN = 200), INTENT(OUT) :: RAD3 - integer, DIMENSION(20), INTENT(IN) :: J - integer, DIMENSION(20), INTENT(IN) :: JPRIM - integer, INTENT(IN) :: PAR - integer, DIMENSION(20), INTENT(IN) :: ANTKO - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE kopp2 (POS, RAD3, J, JPRIM, PAR, ANTKO) + integer, INTENT(IN) :: POS + character (LEN = 200), INTENT(OUT) :: RAD3 + integer, DIMENSION(20), INTENT(IN) :: J + integer, DIMENSION(20), INTENT(IN) :: JPRIM + integer, INTENT(IN) :: PAR + integer, DIMENSION(20), INTENT(IN) :: ANTKO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/lasa1.f90 b/src/appl/jjgen90/lasa1.f90 index 2ba8a1020..b7a48c23e 100644 --- a/src/appl/jjgen90/lasa1.f90 +++ b/src/appl/jjgen90/lasa1.f90 @@ -1,35 +1,35 @@ ! last edited July 31, 1996 - subroutine lasa1(fil, rad, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa1(fil, rad, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reada_I + use reada_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: skal - logical :: slut - character :: rad*200 - integer :: pop(15,0:10,0:1) + integer , intent(in) :: fil + integer :: skal + logical :: slut + character :: rad*200 + integer :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i + integer :: i !----------------------------------------------- - if (.not.slut) then - do i = 1, 200 - rad(i:i) = ' ' - end do - read (fil, 999, end=10) rad - call reada (rad, pop, skal, slut) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa1 + if (.not.slut) then + do i = 1, 200 + rad(i:i) = ' ' + end do + read (fil, 999, end=10) rad + call reada (rad, pop, skal, slut) + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa1 diff --git a/src/appl/jjgen90/lasa1_I.f90 b/src/appl/jjgen90/lasa1_I.f90 index b00777eeb..c4c17035e 100644 --- a/src/appl/jjgen90/lasa1_I.f90 +++ b/src/appl/jjgen90/lasa1_I.f90 @@ -1,12 +1,12 @@ - MODULE lasa1_I + MODULE lasa1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lasa1 (FIL, RAD, POP, SKAL, SLUT) - integer, INTENT(IN) :: FIL - character (LEN = 200), INTENT(OUT) :: RAD - integer, DIMENSION(15,0:10,0:1) :: POP - integer :: SKAL - logical, INTENT(INOUT) :: SLUT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lasa1 (FIL, RAD, POP, SKAL, SLUT) + integer, INTENT(IN) :: FIL + character (LEN = 200), INTENT(OUT) :: RAD + integer, DIMENSION(15,0:10,0:1) :: POP + integer :: SKAL + logical, INTENT(INOUT) :: SLUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/lasa2.f90 b/src/appl/jjgen90/lasa2.f90 index 3c95d470d..e4b3bcedc 100644 --- a/src/appl/jjgen90/lasa2.f90 +++ b/src/appl/jjgen90/lasa2.f90 @@ -1,26 +1,26 @@ ! last edited July 30, 1996 - subroutine lasa2(fil, rad2, rad3, stopp, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa2(fil, rad2, rad3, stopp, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: stopp - logical , intent(inout) :: slut - character :: rad2*200 - character :: rad3*200 + integer , intent(in) :: fil + integer :: stopp + logical , intent(inout) :: slut + character :: rad2*200 + character :: rad3*200 !----------------------------------------------- - if (.not.slut) then - read (fil, 999, end=10) rad2 + if (.not.slut) then + read (fil, 999, end=10) rad2 ! read(fil,999,end=10) rad2(1:stopp) - read (fil, 999, end=10) rad3 + read (fil, 999, end=10) rad3 ! read(fil,999,end=10) rad3(1:stopp+4) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa2 + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa2 diff --git a/src/appl/jjgen90/lasa2_I.f90 b/src/appl/jjgen90/lasa2_I.f90 index 045601390..7ba9d8a6b 100644 --- a/src/appl/jjgen90/lasa2_I.f90 +++ b/src/appl/jjgen90/lasa2_I.f90 @@ -1,12 +1,12 @@ - MODULE lasa2_I + MODULE lasa2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lasa2 (FIL, RAD2, RAD3, STOPP, SLUT) - integer, INTENT(IN) :: FIL - character (LEN = 200) :: RAD2 - character (LEN = 200) :: RAD3 - integer :: STOPP - logical, INTENT(INOUT) :: SLUT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lasa2 (FIL, RAD2, RAD3, STOPP, SLUT) + integer, INTENT(IN) :: FIL + character (LEN = 200) :: RAD2 + character (LEN = 200) :: RAD3 + integer :: STOPP + logical, INTENT(INOUT) :: SLUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/lasax-reada.f90 b/src/appl/jjgen90/lasax-reada.f90 index 4f25dca4c..e5a621628 100644 --- a/src/appl/jjgen90/lasax-reada.f90 +++ b/src/appl/jjgen90/lasax-reada.f90 @@ -1,140 +1,140 @@ ! last edited July 31, 1996 - subroutine lasa1(fil, rad, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa1(fil, rad, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reada_I + use reada_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: skal - logical :: slut - character :: rad*200 - integer :: pop(15,0:10,0:1) + integer , intent(in) :: fil + integer :: skal + logical :: slut + character :: rad*200 + integer :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i + integer :: i !----------------------------------------------- - if (.not.slut) then - do i = 1, 200 - rad(i:i) = ' ' - end do - read (fil, 999, end=10) rad - call reada (rad, pop, skal, slut) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa1 + if (.not.slut) then + do i = 1, 200 + rad(i:i) = ' ' + end do + read (fil, 999, end=10) rad + call reada (rad, pop, skal, slut) + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa1 ! last edited July 30, 1996 - subroutine lasa2(fil, rad2, rad3, stopp, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa2(fil, rad2, rad3, stopp, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: stopp - logical , intent(inout) :: slut - character :: rad2*200 - character :: rad3*200 + integer , intent(in) :: fil + integer :: stopp + logical , intent(inout) :: slut + character :: rad2*200 + character :: rad3*200 !----------------------------------------------- - if (.not.slut) then - read (fil, 999, end=10) rad2 + if (.not.slut) then + read (fil, 999, end=10) rad2 ! read(fil,999,end=10) rad2(1:stopp) - read (fil, 999, end=10) rad3 + read (fil, 999, end=10) rad3 ! read(fil,999,end=10) rad3(1:stopp+4) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa2 + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa2 ! last edited July 31, 1996 - subroutine reada(rad1, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reada(rad1, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: skal - logical , intent(out) :: slut - character , intent(in) :: rad1*200 - integer , intent(out) :: pop(15,0:10,0:1) + integer , intent(inout) :: skal + logical , intent(out) :: slut + character , intent(in) :: rad1*200 + integer , intent(out) :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k, n, l, antal, stopp - character, dimension(0:10) :: orb + integer :: i, j, k, n, l, antal, stopp + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - slut = .FALSE. - do n = 1, 15 - pop(n,:min(10,n-1),:1) = 0 - end do - stopp = skal - 1 - l10: do i = 0, stopp - j = 9*i - if (rad1(j+3:j+3) == ' ') return - skal = i + 1 - slut = .TRUE. - n = ichar(rad1(j+3:j+3)) - ichar('0') - if (rad1(j+2:j+2) == '1') n = n + 10 - if (n<=15 .and. n>=1) then - if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 0 - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - else - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - endif - else - slut = .TRUE. - return - endif - end do l10 - return - end subroutine reada + 'n'/ + slut = .FALSE. + do n = 1, 15 + pop(n,:min(10,n-1),:1) = 0 + end do + stopp = skal - 1 + l10: do i = 0, stopp + j = 9*i + if (rad1(j+3:j+3) == ' ') return + skal = i + 1 + slut = .TRUE. + n = ichar(rad1(j+3:j+3)) - ichar('0') + if (rad1(j+2:j+2) == '1') n = n + 10 + if (n<=15 .and. n>=1) then + if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 0 + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + else + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + endif + else + slut = .TRUE. + return + endif + end do l10 + return + end subroutine reada diff --git a/src/appl/jjgen90/lika.f90 b/src/appl/jjgen90/lika.f90 index 209744dc4..d0875ebb2 100644 --- a/src/appl/jjgen90/lika.f90 +++ b/src/appl/jjgen90/lika.f90 @@ -1,30 +1,30 @@ - + ! last edited September 23, 1995 - logical function lika (pop0, pop1) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + logical function lika (pop0, pop1) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pop0(15,0:10,0:1) - integer , intent(in) :: pop1(15,0:10,0:1) + integer , intent(in) :: pop0(15,0:10,0:1) + integer , intent(in) :: pop1(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k - logical :: dum + integer :: i, j, k + logical :: dum !----------------------------------------------- - dum = .TRUE. - l10: do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, 1 - dum = dum .and. pop0(i,j,k)==pop1(i,j,k) - if (dum) cycle - exit l10 - end do - end do - end do l10 - lika = dum - return - end function lika + dum = .TRUE. + l10: do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, 1 + dum = dum .and. pop0(i,j,k)==pop1(i,j,k) + if (dum) cycle + exit l10 + end do + end do + end do l10 + lika = dum + return + end function lika diff --git a/src/appl/jjgen90/lika_I.f90 b/src/appl/jjgen90/lika_I.f90 index ebe5be67d..7a8d38d2b 100644 --- a/src/appl/jjgen90/lika_I.f90 +++ b/src/appl/jjgen90/lika_I.f90 @@ -1,9 +1,9 @@ - MODULE lika_I + MODULE lika_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - LOGICAL FUNCTION lika (POP0, POP1) - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP0 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 - END FUNCTION - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + LOGICAL FUNCTION lika (POP0, POP1) + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP0 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/lockad.f90 b/src/appl/jjgen90/lockad.f90 index 898a34310..972362573 100644 --- a/src/appl/jjgen90/lockad.f90 +++ b/src/appl/jjgen90/lockad.f90 @@ -1,80 +1,80 @@ ! last edited Februar 20, 1996 - subroutine lockad(closed, med, slut, expand) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lockad(closed, med, slut, expand) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(out) :: slut - logical , intent(in) :: expand - logical , intent(out) :: closed(15,0:10) - logical , intent(out) :: med(15,0:10) + logical , intent(out) :: slut + logical , intent(in) :: expand + logical , intent(out) :: closed(15,0:10) + logical , intent(out) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, n, l - character :: rad*1000 - character, dimension(0:10) :: orb + integer :: i, j, n, l + character :: rad*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - if (expand) then - read (fil_2, *, end=40) - read (fil_2, 100, end=40) rad - else - read (fil_1, *, end=40) - read (fil_1, 100, end=40) rad - endif - do n = 1, 15 - closed(n,1:min(10,n-1)) = .FALSE. - end do - l30: do i = 0, 205 - j = i*5 - n = ichar(rad(j+3:j+3)) - ichar('0') - if (n>=1 .and. n<=15) then - do l = 0, min(10,n - 1) - if (rad(j+4:j+4) /= orb(l)) cycle - closed(n,l) = .TRUE. - cycle l30 - end do - else - exit l30 - endif - end do l30 - if (expand) then - read (fil_2, *, end=40) - read (fil_2, 100, end=40) rad - else - read (fil_1, *, end=40) - read (fil_1, 100, end=40) rad - endif - do n = 1, 15 - med(n,1:min(10,n-1)) = .FALSE. - end do - l130: do i = 0, 205 - j = i*5 - n = ichar(rad(j+3:j+3)) - ichar('0') - if (n>=1 .and. n<=15) then - do l = 0, min(10,n - 1) - if (rad(j+4:j+4) /= orb(l)) cycle - med(n,l) = .TRUE. - cycle l130 - end do - else - return - endif - end do l130 - - return - 40 continue - slut = .TRUE. - return - 100 format(a) - return - end subroutine lockad + 'n'/ + if (expand) then + read (fil_2, *, end=40) + read (fil_2, 100, end=40) rad + else + read (fil_1, *, end=40) + read (fil_1, 100, end=40) rad + endif + do n = 1, 15 + closed(n,1:min(10,n-1)) = .FALSE. + end do + l30: do i = 0, 205 + j = i*5 + n = ichar(rad(j+3:j+3)) - ichar('0') + if (n>=1 .and. n<=15) then + do l = 0, min(10,n - 1) + if (rad(j+4:j+4) /= orb(l)) cycle + closed(n,l) = .TRUE. + cycle l30 + end do + else + exit l30 + endif + end do l30 + if (expand) then + read (fil_2, *, end=40) + read (fil_2, 100, end=40) rad + else + read (fil_1, *, end=40) + read (fil_1, 100, end=40) rad + endif + do n = 1, 15 + med(n,1:min(10,n-1)) = .FALSE. + end do + l130: do i = 0, 205 + j = i*5 + n = ichar(rad(j+3:j+3)) - ichar('0') + if (n>=1 .and. n<=15) then + do l = 0, min(10,n - 1) + if (rad(j+4:j+4) /= orb(l)) cycle + med(n,l) = .TRUE. + cycle l130 + end do + else + return + endif + end do l130 + + return + 40 continue + slut = .TRUE. + return + 100 format(a) + return + end subroutine lockad diff --git a/src/appl/jjgen90/lockad_I.f90 b/src/appl/jjgen90/lockad_I.f90 index 13328f6cd..8ef63330e 100644 --- a/src/appl/jjgen90/lockad_I.f90 +++ b/src/appl/jjgen90/lockad_I.f90 @@ -1,12 +1,12 @@ - MODULE lockad_I + MODULE lockad_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lockad (CLOSED, MED, SLUT, EXPAND) - logical, DIMENSION(15,0:10), INTENT(OUT) :: CLOSED - logical, DIMENSION(15,0:10), INTENT(OUT) :: MED - logical, INTENT(OUT) :: SLUT - logical, INTENT(IN) :: EXPAND +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lockad (CLOSED, MED, SLUT, EXPAND) + logical, DIMENSION(15,0:10), INTENT(OUT) :: CLOSED + logical, DIMENSION(15,0:10), INTENT(OUT) :: MED + logical, INTENT(OUT) :: SLUT + logical, INTENT(IN) :: EXPAND !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/matain.f90 b/src/appl/jjgen90/matain.f90 index e709dadeb..f0858fda8 100644 --- a/src/appl/jjgen90/matain.f90 +++ b/src/appl/jjgen90/matain.f90 @@ -1,384 +1,384 @@ ! last edited November 1, 1996 subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & - minj, maxj, lim, dubbel) -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:24:37 1/ 2/07 -!...Switches: + minj, maxj, lim, dubbel) +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:24:37 1/ 2/07 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer , intent(out) :: skal - integer :: nmax - integer , intent(out) :: anel - integer , intent(out) :: par - integer :: minj - integer :: maxj - integer :: org(15,0:10) - integer , intent(inout) :: low(15,0:10) - integer :: lim(15) - logical , intent(inout) :: lock(15,0:10) - logical , intent(inout) :: closed(15,0:10) - logical , intent(out) :: dubbel(15,0:10) + integer :: varmax + integer , intent(out) :: skal + integer :: nmax + integer , intent(out) :: anel + integer , intent(out) :: par + integer :: minj + integer :: maxj + integer :: org(15,0:10) + integer , intent(inout) :: low(15,0:10) + integer :: lim(15) + logical , intent(inout) :: lock(15,0:10) + logical , intent(inout) :: closed(15,0:10) + logical , intent(out) :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- integer :: anela, anelb, resl, i, j, lmax, em, nenter, block, mshell, enn& - , tmp, cormax - logical :: log_all, lima, open_c, clos_c - character :: x - character , dimension(0:10) :: orb - character , dimension(0:20) :: l - character :: y*3 + , tmp, cormax + logical :: log_all, lima, open_c, clos_c + character :: x + character , dimension(0:10) :: orb + character , dimension(0:20) :: l + character :: y*3 !----------------------------------------------- data (l(i),i=0,20)/ 'S', 'P', 'D', 'F', 'G', 'H', 'I', 'K', 'L', 'M', 'N'& - , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ + , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - - do i = 1, 15 - org(i,:min(i-1,10)) = 0 - end do - skal = 20 - 60 continue - write (*, 200) 'Highest principal quantum number, n? (1..15)' - read (*, *, err=60) nmax - nmax = max(nmax,1) - nmax = min(nmax,15) - write (logfil, *) nmax, ' Highest principal quantum number.' - 70 continue + 'n'/ + + do i = 1, 15 + org(i,:min(i-1,10)) = 0 + end do + skal = 20 + 60 continue + write (*, 200) 'Highest principal quantum number, n? (1..15)' + read (*, *, err=60) nmax + nmax = max(nmax,1) + nmax = min(nmax,15) + write (logfil, *) nmax, ' Highest principal quantum number.' + 70 continue write (*, 300) 'Highest orbital angular momentum, l? (s..', orb(min(10,& - nmax-1)), ')' - read (*, 1000) x - lmax = -1 - do i = 0, min(10,nmax - 1) - if (x /= orb(i)) cycle - lmax = i - end do - if (lmax == (-1)) go to 70 - write (logfil, *) lmax, ' Highest orbital angular momentum.' - write (*, 200) 'Are all these nl-subshells active? (n/*)' - read (*, 1000) x - log_all = .not.(x=='n' .or. x=='N') - write (logfil, *) log_all, ' all subshells active.' - lim = 0 - if (nmax >= 2) then - write (*, 200) 'Limitations on population of n-subshells? (y/*)' - read (*, 1000) x - lima = x=='y' .or. x=='Y' - write (logfil, *) lima, ' limitations on population of n-subshells.' - if (lima) then - mshell = 0 - do i = 1, nmax - 1 - mshell = mshell + 2*i*i - 83 continue - if (i == 1) then - write (*, 200) 'Minimum number of electrons with n=1? (0..2)' - else if (i < 10) then - if (mshell < 100) then + nmax-1)), ')' + read (*, 1000) x + lmax = -1 + do i = 0, min(10,nmax - 1) + if (x /= orb(i)) cycle + lmax = i + end do + if (lmax == (-1)) go to 70 + write (logfil, *) lmax, ' Highest orbital angular momentum.' + write (*, 200) 'Are all these nl-subshells active? (n/*)' + read (*, 1000) x + log_all = .not.(x=='n' .or. x=='N') + write (logfil, *) log_all, ' all subshells active.' + lim = 0 + if (nmax >= 2) then + write (*, 200) 'Limitations on population of n-subshells? (y/*)' + read (*, 1000) x + lima = x=='y' .or. x=='Y' + write (logfil, *) lima, ' limitations on population of n-subshells.' + if (lima) then + mshell = 0 + do i = 1, nmax - 1 + mshell = mshell + 2*i*i + 83 continue + if (i == 1) then + write (*, 200) 'Minimum number of electrons with n=1? (0..2)' + else if (i < 10) then + if (mshell < 100) then write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..', mshell, ')' - else + '? (0..', mshell, ')' + else write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - else + '? (0..)' + endif + else write (*, 202) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - read (*, *, err=83) lim(i) - lim(i) = min0(mshell,lim(i)) + '? (0..)' + endif + read (*, *, err=83) lim(i) + lim(i) = min0(mshell,lim(i)) write (logfil, *) lim(i), & - ' is minimum number of electrons with n =', i - end do - endif - endif - 90 continue - if (nmax < 10) then + ' is minimum number of electrons with n =', i + end do + endif + endif + 90 continue + if (nmax < 10) then write (*, 200) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - else + nmax, ')' + else write (*, 202) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - endif - read (*, *, err=90) nenter - nenter = max(nenter,1) - nenter = min(nenter,nmax) - write (logfil, *) nenter, ' highest n-number.' - if (nenter >= 1) then - write (*, 200) 'Predefine open, closed or no core? (o/c/*)' - read (*, 1000) x - open_c = x=='O' .or. x=='o' - clos_c = x=='C' .or. x=='c' - write (logfil, *) 'Predefined core:', x - if (open_c .or. clos_c) then - 92 continue - write (*, 200) 'Select core,' + nmax, ')' + endif + read (*, *, err=90) nenter + nenter = max(nenter,1) + nenter = min(nenter,nmax) + write (logfil, *) nenter, ' highest n-number.' + if (nenter >= 1) then + write (*, 200) 'Predefine open, closed or no core? (o/c/*)' + read (*, 1000) x + open_c = x=='O' .or. x=='o' + clos_c = x=='C' .or. x=='c' + write (logfil, *) 'Predefined core:', x + if (open_c .or. clos_c) then + 92 continue + write (*, 200) 'Select core,' write (*, 200) & - ' 1: He ( 1s(2) = 2 electrons)' + ' 1: He ( 1s(2) = 2 electrons)' if (nenter >= 2) write (*, 200) & - ' 2: Ne ([He] + 2s(2)2p(6) = 10 electrons)' + ' 2: Ne ([He] + 2s(2)2p(6) = 10 electrons)' if (nenter >= 3) write (*, 200) & - ' 3: Ar ([Ne] + 3s(2)3p(6) = 18 electrons)' + ' 3: Ar ([Ne] + 3s(2)3p(6) = 18 electrons)' if (nenter >= 4) write (*, 200) & - ' 4: Kr ([Ar] + 3d(10)4s(2)4p(6) = 36 electrons)' + ' 4: Kr ([Ar] + 3d(10)4s(2)4p(6) = 36 electrons)' if (nenter >= 5) write (*, 200) & - ' 5: Xe ([Kr] + 4d(10)5s(2)5p(6) = 54 electrons)' + ' 5: Xe ([Kr] + 4d(10)5s(2)5p(6) = 54 electrons)' if (nenter >= 6) write (*, 200) & - ' 6: Rn ([Xe] + 4f(16)5d(10)6s(2)6p(6) = 86 electrons)' - read (*, *, err=92) cormax - if (cormax > nenter) go to 92 - if (cormax >= 1) then - write (logfil, *) 'Core n=', cormax - if (clos_c) then - do i = 1, cormax - do j = 0, min(3,i - 1) - closed(i,j) = .TRUE. - org(i,j) = 2 + 4*j - end do - end do - else - do i = 1, cormax - do j = 0, min(3,i - 1) - org(i,j) = 2 + 4*j - end do - end do - endif - select case (cormax) - case (3) - org(3,2) = 0 - if (clos_c) closed(3,2) = .FALSE. - case (4) - org(4,2) = 0 - org(4,3) = 0 - if (clos_c) then - closed(4,2) = .FALSE. - closed(4,3) = .FALSE. - endif - case (5) - org(4,3) = 0 - org(5,2) = 0 - org(5,3) = 0 - if (clos_c) then - closed(4,3) = .FALSE. - closed(5,2) = .FALSE. - closed(5,3) = .FALSE. - endif - case (6) - org(5,3) = 0 - org(6,2) = 0 - org(6,3) = 0 - if (clos_c) then - closed(5,3) = .FALSE. - closed(6,2) = .FALSE. - closed(6,3) = .FALSE. - endif - end select - else - write (logfil, *) 'Core cancelled' - endif - endif - endif - anela = 0 - anelb = 0 - anel = 0 - par = 0 - block = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - low(i,j) = 0 - dubbel(i,j) = .FALSE. - if (nmax>=i .and. lmax>=j .and. org(i,j)==0) then - if (nenter >= i) then - em = 2 + 4*j - if (em < 10) then - 100 continue - if (i <= 9) then + ' 6: Rn ([Xe] + 4f(16)5d(10)6s(2)6p(6) = 86 electrons)' + read (*, *, err=92) cormax + if (cormax > nenter) go to 92 + if (cormax >= 1) then + write (logfil, *) 'Core n=', cormax + if (clos_c) then + do i = 1, cormax + do j = 0, min(3,i - 1) + closed(i,j) = .TRUE. + org(i,j) = 2 + 4*j + end do + end do + else + do i = 1, cormax + do j = 0, min(3,i - 1) + org(i,j) = 2 + 4*j + end do + end do + endif + select case (cormax) + case (3) + org(3,2) = 0 + if (clos_c) closed(3,2) = .FALSE. + case (4) + org(4,2) = 0 + org(4,3) = 0 + if (clos_c) then + closed(4,2) = .FALSE. + closed(4,3) = .FALSE. + endif + case (5) + org(4,3) = 0 + org(5,2) = 0 + org(5,3) = 0 + if (clos_c) then + closed(4,3) = .FALSE. + closed(5,2) = .FALSE. + closed(5,3) = .FALSE. + endif + case (6) + org(5,3) = 0 + org(6,2) = 0 + org(6,3) = 0 + if (clos_c) then + closed(5,3) = .FALSE. + closed(6,2) = .FALSE. + closed(6,3) = .FALSE. + endif + end select + else + write (logfil, *) 'Core cancelled' + endif + endif + endif + anela = 0 + anelb = 0 + anel = 0 + par = 0 + block = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + low(i,j) = 0 + dubbel(i,j) = .FALSE. + if (nmax>=i .and. lmax>=j .and. org(i,j)==0) then + if (nenter >= i) then + em = 2 + 4*j + if (em < 10) then + 100 continue + if (i <= 9) then write (*, 200) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 202) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (*, *, err=100) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 100 - else - 101 continue - if (i < 10) then + '? (0..', em, ')' + endif + read (*, *, err=100) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 100 + else + 101 continue + if (i < 10) then write (*, 201) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 203) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (*, *, err=101) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 101 - endif + '? (0..', em, ')' + endif + read (*, *, err=101) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 101 + endif write (logfil, *) org(i,j), ' number of electrons in', i, orb& - (j) - anel = anel + org(i,j) - par = mod(par + j*org(i,j),2) - if (log_all) then - lock(i,j) = .FALSE. - closed(i,j) = .FALSE. - else - if (org(i,j) == em) then - if (org(i,j) <= 10) then + (j) + anel = anel + org(i,j) + par = mod(par + j*org(i,j),2) + if (log_all) then + lock(i,j) = .FALSE. + closed(i,j) = .FALSE. + else + if (org(i,j) == em) then + if (org(i,j) <= 10) then write (*, 201) & 'Closed, inactive, active or minimum? (c/i/*/0..'& - , org(i,j) - 1, ')' - else + , org(i,j) - 1, ')' + else write (*, 202) & 'Closed, inactive, active or minimum? (c/i/*/0..'& - , org(i,j) - 1, ')' - endif - read (*, 1000) y - write (logfil, *) y, ' closed, inactive, etc...' - closed(i,j) = y(1:1)=='c' .or. y(1:1)=='C' + , org(i,j) - 1, ')' + endif + read (*, 1000) y + write (logfil, *) y, ' closed, inactive, etc...' + closed(i,j) = y(1:1)=='c' .or. y(1:1)=='C' lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' .or. closed(i,& - j) - if (closed(i,j)) block = block + em - else - if (org(i,j) > 1) then - if (org(i,j) <= 10) then + j) + if (closed(i,j)) block = block + em + else + if (org(i,j) > 1) then + if (org(i,j) <= 10) then write (*, 201) & 'Inactive, active or minimum? (i/*/0..', org(i& - ,j) - 1, ')' - else + ,j) - 1, ')' + else write (*, 202) & - 'Closed, inactive, active or minimum? (c/i/*/0..', org(i,j) - 1, ')' - endif - else if (org(i,j) == 1) then - write (*, 201) 'Inactive or active? (i/*)' - else + 'Closed, inactive, active or minimum? (c/i/*/0..', org(i,j) - 1, ')' + endif + else if (org(i,j) == 1) then + write (*, 201) 'Inactive or active? (i/*)' + else write (*, 400) 'Inactive, active or double ', & - 'excited? (i/*/d)' - endif - read (*, 1000) y - write (logfil, *) y, ' inactive, active, etc...' + 'excited? (i/*/d)' + endif + read (*, 1000) y + write (logfil, *) y, ' inactive, active, etc...' if (org(i,j) == 0) dubbel(i,j) = y(1:1)=='d' .or. y(1:1& - )=='D' - lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' - closed(i,j) = .FALSE. - endif - if (y(1:1)>='0' .and. y(1:1)<='9') then - if (org(i,j) > 0) then - tmp = ichar(y(1:1)) - ichar('0') + )=='D' + lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' + closed(i,j) = .FALSE. + endif + if (y(1:1)>='0' .and. y(1:1)<='9') then + if (org(i,j) > 0) then + tmp = ichar(y(1:1)) - ichar('0') if (y(2:2)>='1' .and. y(2:2)<='9') tmp = tmp*10 + & - ichar(y(2:2)) - ichar('0') - low(i,j) = min(org(i,j),tmp) - endif - endif - endif - if (.not.lock(i,j)) anela = anela + org(i,j) - else if (log_all) then - org(i,j) = 0 - lock(i,j) = .FALSE. - closed(i,j) = .FALSE. - else - org(i,j) = 0 - closed(i,j) = .FALSE. - if (i < 10) then + ichar(y(2:2)) - ichar('0') + low(i,j) = min(org(i,j),tmp) + endif + endif + endif + if (.not.lock(i,j)) anela = anela + org(i,j) + else if (log_all) then + org(i,j) = 0 + lock(i,j) = .FALSE. + closed(i,j) = .FALSE. + else + org(i,j) = 0 + closed(i,j) = .FALSE. + if (i < 10) then write (*, 204) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - else + 'doubled excited? (i/*/d)' + else write (*, 205) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - endif - read (*, 1000) x - write (logfil, *) x, i, orb(j), ' inactive, active, etc...' - dubbel(i,j) = x=='d' .or. x=='D' - lock(i,j) = x=='i' .or. x=='I' - endif - else if (org(i,j) /= 0) then - write (*, 204) i, orb(j), ' is part of the predefined core.' - if (open_c) then - if (log_all) then - closed(i,j) = .FALSE. - lock(i,j) = .FALSE. - else - if (org(i,j) <= 10) then + 'doubled excited? (i/*/d)' + endif + read (*, 1000) x + write (logfil, *) x, i, orb(j), ' inactive, active, etc...' + dubbel(i,j) = x=='d' .or. x=='D' + lock(i,j) = x=='i' .or. x=='I' + endif + else if (org(i,j) /= 0) then + write (*, 204) i, orb(j), ' is part of the predefined core.' + if (open_c) then + if (log_all) then + closed(i,j) = .FALSE. + lock(i,j) = .FALSE. + else + if (org(i,j) <= 10) then write (*, 201) & 'Closed, inactive, active or minimum? (c/i/*/0..', & - org(i,j) - 1, ')' - else + org(i,j) - 1, ')' + else write (*, 202) & 'Closed, inactive, active or minimum? (c/i/*/0..', & - org(i,j) - 1, ')' - endif - read (*, 1000) y - write (logfil, *) y, ' closed, inactive, etc...' - closed(i,j) = y(1:1)=='c' .or. y(1:1)=='C' - lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' .or. closed(i,j) - if (y(1:1)>='0' .and. y(1:1)<='9') then - if (org(i,j) > 0) then - tmp = ichar(y(1:1)) - ichar('0') + org(i,j) - 1, ')' + endif + read (*, 1000) y + write (logfil, *) y, ' closed, inactive, etc...' + closed(i,j) = y(1:1)=='c' .or. y(1:1)=='C' + lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' .or. closed(i,j) + if (y(1:1)>='0' .and. y(1:1)<='9') then + if (org(i,j) > 0) then + tmp = ichar(y(1:1)) - ichar('0') if (y(2:2)>='1' .and. y(2:2)<='9') tmp = tmp*10 + & - ichar(y(2:2)) - ichar('0') - low(i,j) = min(org(i,j),tmp) - endif - endif - endif - if (.not.lock(i,j)) anela = anela + org(i,j) - else - lock(i,j) = closed(i,j) - endif - if (closed(i,j)) block = block + org(i,j) - anel = anel + org(i,j) - else - org(i,j) = 0 - lock(i,j) = .TRUE. - closed(i,j) = .FALSE. - endif - anelb = anelb + low(i,j) - end do - lim(i) = lim(i) - block - lim(i) = max0(0,lim(i)) - end do - 1100 continue + ichar(y(2:2)) - ichar('0') + low(i,j) = min(org(i,j),tmp) + endif + endif + endif + if (.not.lock(i,j)) anela = anela + org(i,j) + else + lock(i,j) = closed(i,j) + endif + if (closed(i,j)) block = block + org(i,j) + anel = anel + org(i,j) + else + org(i,j) = 0 + lock(i,j) = .TRUE. + closed(i,j) = .FALSE. + endif + anelb = anelb + low(i,j) + end do + lim(i) = lim(i) - block + lim(i) = max0(0,lim(i)) + end do + 1100 continue write (*, 400) 'Resulting 2*J-number? lower, higher ', & - '(J=1 -> 2*J=2 etc.)' - read (*, *, err=1100) minj, maxj - if (anel == 2*(anel/2)) then - if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be even' - go to 1100 - endif - else - if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be odd' - go to 1100 - endif - endif - write (logfil, *) minj, ' to', maxj, ' is the resulting term.' - anelb = anela - anelb - 1200 continue - if (anelb < 10) then - write (*, 200) 'Number of excitations = ? (0..', anelb, ')' - read (*, *, err=1200) varmax - else - write (*, 202) 'Number of excitations = ? (0..', anelb, ')' - read (*, *, err=1200) varmax - endif - write (logfil, *) varmax, ' number of excitations.' - 200 format(' ',a,i1,a,a,i1,a) - 201 format(' ',a,i1,a,a,i2,a) - 202 format(' ',a,i2,a,a,i1,a) - 203 format(' ',a,i2,a,a,i2,a) - 204 format(' ',i1,3a) - 205 format(' ',i2,3a) - 206 format(' ',i1,a,a,i2,a) - 207 format(' ',i2,a,a,i2,a) - 208 format(' ',a,i1,a,i2,a) - 300 format(' ',3a) - 400 format(' ',2a,i1,a) - 402 format(' ',2a,i2,a) - 1000 format(3a) - 2000 format(i1,2a) - 3000 format(a,i2,2a) - return - end subroutine matain + '(J=1 -> 2*J=2 etc.)' + read (*, *, err=1100) minj, maxj + if (anel == 2*(anel/2)) then + if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be even' + go to 1100 + endif + else + if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be odd' + go to 1100 + endif + endif + write (logfil, *) minj, ' to', maxj, ' is the resulting term.' + anelb = anela - anelb + 1200 continue + if (anelb < 10) then + write (*, 200) 'Number of excitations = ? (0..', anelb, ')' + read (*, *, err=1200) varmax + else + write (*, 202) 'Number of excitations = ? (0..', anelb, ')' + read (*, *, err=1200) varmax + endif + write (logfil, *) varmax, ' number of excitations.' + 200 format(' ',a,i1,a,a,i1,a) + 201 format(' ',a,i1,a,a,i2,a) + 202 format(' ',a,i2,a,a,i1,a) + 203 format(' ',a,i2,a,a,i2,a) + 204 format(' ',i1,3a) + 205 format(' ',i2,3a) + 206 format(' ',i1,a,a,i2,a) + 207 format(' ',i2,a,a,i2,a) + 208 format(' ',a,i1,a,i2,a) + 300 format(' ',3a) + 400 format(' ',2a,i1,a) + 402 format(' ',2a,i2,a) + 1000 format(3a) + 2000 format(i1,2a) + 3000 format(a,i2,2a) + return + end subroutine matain diff --git a/src/appl/jjgen90/matain_I.f90 b/src/appl/jjgen90/matain_I.f90 index 5a9c7b3ff..59491ef72 100644 --- a/src/appl/jjgen90/matain_I.f90 +++ b/src/appl/jjgen90/matain_I.f90 @@ -1,22 +1,22 @@ - MODULE matain_I + MODULE matain_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 12:22:13 1/ 2/07 +!...Generated by Pacific-Sierra Research 77to90 4.3E 12:22:13 1/ 2/07 SUBROUTINE matain (ORG, LOCK, CLOSED, VARMAX, SKAL, NMAX, ANEL, PAR, LOW& - , MINJ, MAXJ, LIM, DUBBEL) - INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK - LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED - INTEGER, INTENT(IN) :: VARMAX - INTEGER, INTENT(OUT) :: SKAL - INTEGER, INTENT(OUT) :: NMAX - INTEGER, INTENT(OUT) :: ANEL - INTEGER, INTENT(OUT) :: PAR - INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: LOW - INTEGER, INTENT(IN) :: MINJ - INTEGER, INTENT(IN) :: MAXJ - INTEGER, DIMENSION(15), INTENT(INOUT) :: LIM - LOGICAL, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL + , MINJ, MAXJ, LIM, DUBBEL) + INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK + LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED + INTEGER, INTENT(IN) :: VARMAX + INTEGER, INTENT(OUT) :: SKAL + INTEGER, INTENT(OUT) :: NMAX + INTEGER, INTENT(OUT) :: ANEL + INTEGER, INTENT(OUT) :: PAR + INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: LOW + INTEGER, INTENT(IN) :: MINJ + INTEGER, INTENT(IN) :: MAXJ + INTEGER, DIMENSION(15), INTENT(INOUT) :: LIM + LOGICAL, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/matbin.f90 b/src/appl/jjgen90/matbin.f90 index be6c2b76d..f847bf7fc 100644 --- a/src/appl/jjgen90/matbin.f90 +++ b/src/appl/jjgen90/matbin.f90 @@ -1,263 +1,263 @@ ! last edited August 2, 1996 subroutine matbin(org, lock, closed, varmax, skal, second, anel0, par0, & - low, nmax, lim, dubbel, minj, maxj) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + low, nmax, lim, dubbel, minj, maxj) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer , intent(out) :: skal - integer , intent(in) :: anel0 - integer , intent(out) :: par0 - integer :: nmax - integer :: minj - integer :: maxj - logical , intent(inout) :: second - integer :: org(15,0:10) - integer , intent(inout) :: low(15,0:10) - integer :: lim(15) - logical , intent(inout) :: lock(15,0:10) - logical , intent(inout) :: closed(15,0:10) - logical , intent(out) :: dubbel(15,0:10) + integer :: varmax + integer , intent(out) :: skal + integer , intent(in) :: anel0 + integer , intent(out) :: par0 + integer :: nmax + integer :: minj + integer :: maxj + logical , intent(inout) :: second + integer :: org(15,0:10) + integer , intent(inout) :: low(15,0:10) + integer :: lim(15) + logical , intent(inout) :: lock(15,0:10) + logical , intent(inout) :: closed(15,0:10) + logical , intent(out) :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- integer :: anel, par, i, j, lmax, em, nenter, anela, anelb, block, mshell& - , tmp - logical :: all, lima - character :: x - character , dimension(0:10) :: orb - character , dimension(0:20) :: l - character :: y*2 + , tmp + logical :: all, lima + character :: x + character , dimension(0:10) :: orb + character , dimension(0:20) :: l + character :: y*2 !----------------------------------------------- ! data (l(i),i=0,20)/ 'S', 'P', 'D', 'F', 'G', 'H', 'I', 'K', 'L', 'M', 'N'& - , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ + , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - - 40 continue - if (.not.second) then - write (*, 200) 'Generate another list? (y/*)' - read (*, 1000) x - second = x=='y' .or. x=='Y' - write (logfil, *) second, ' Generate another list.' - if (.not.second) return - endif - anel = 0 - anela = 0 - anelb = 0 - par = 0 - skal = 20 - 60 continue - write (*, 200) 'Highest n-number? (1..15)' - read (*, *, err=60) nmax - nmax = max(nmax,1) - nmax = min(nmax,15) - write (logfil, *) nmax, ' Highest principal quantum number.' - 70 continue - write (*, 400) 'Highest l-number? (s..', orb(min(10,nmax-1)), ')' - read (*, 1000) x - lmax = -1 - do i = 0, min(10,nmax - 1) - if (x /= orb(i)) cycle - lmax = i - end do - if (lmax == (-1)) go to 70 - write (logfil, *) lmax, ' Highest orbital angular momentum.' - write (*, 200) 'Are all these nl-subshells active? (n/*)' - read (*, 1000) x - all = .not.(x=='n' .or. x=='N') - write (logfil, *) all, ' all subshells active.' - lim = 0 - if (nmax >= 2) then - write (*, 200) 'Limitations on population of n-subshells? (y/*)' - read (*, 1000) x - lima = x=='y' .or. x=='Y' - write (logfil, *) lima, ' limitations on population of n-subshells.' - if (lima) then - mshell = 0 - do i = 1, nmax - 1 - mshell = mshell + 2*i*i - 83 continue - if (i == 1) then - write (*, 200) 'Minimum number of electrons with n=1? (0..2)' - else if (i < 10) then - if (mshell < 100) then + 'n'/ + + 40 continue + if (.not.second) then + write (*, 200) 'Generate another list? (y/*)' + read (*, 1000) x + second = x=='y' .or. x=='Y' + write (logfil, *) second, ' Generate another list.' + if (.not.second) return + endif + anel = 0 + anela = 0 + anelb = 0 + par = 0 + skal = 20 + 60 continue + write (*, 200) 'Highest n-number? (1..15)' + read (*, *, err=60) nmax + nmax = max(nmax,1) + nmax = min(nmax,15) + write (logfil, *) nmax, ' Highest principal quantum number.' + 70 continue + write (*, 400) 'Highest l-number? (s..', orb(min(10,nmax-1)), ')' + read (*, 1000) x + lmax = -1 + do i = 0, min(10,nmax - 1) + if (x /= orb(i)) cycle + lmax = i + end do + if (lmax == (-1)) go to 70 + write (logfil, *) lmax, ' Highest orbital angular momentum.' + write (*, 200) 'Are all these nl-subshells active? (n/*)' + read (*, 1000) x + all = .not.(x=='n' .or. x=='N') + write (logfil, *) all, ' all subshells active.' + lim = 0 + if (nmax >= 2) then + write (*, 200) 'Limitations on population of n-subshells? (y/*)' + read (*, 1000) x + lima = x=='y' .or. x=='Y' + write (logfil, *) lima, ' limitations on population of n-subshells.' + if (lima) then + mshell = 0 + do i = 1, nmax - 1 + mshell = mshell + 2*i*i + 83 continue + if (i == 1) then + write (*, 200) 'Minimum number of electrons with n=1? (0..2)' + else if (i < 10) then + if (mshell < 100) then write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..', mshell, ')' - else + '? (0..', mshell, ')' + else write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - else + '? (0..)' + endif + else write (*, 202) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - read (*, *, err=83) lim(i) - lim(i) = min0(mshell,lim(i)) + '? (0..)' + endif + read (*, *, err=83) lim(i) + lim(i) = min0(mshell,lim(i)) write (logfil, *) lim(i), & - ' is minimum number of electrons with n =', i - end do - endif - endif - 95 continue - if (nmax < 10) then + ' is minimum number of electrons with n =', i + end do + endif + endif + 95 continue + if (nmax < 10) then write (*, 200) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - else + nmax, ')' + else write (*, 202) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - endif - read (*, *, err=95) nenter - nenter = max(nenter,1) - nenter = min(nenter,nmax) - write (logfil, *) nenter, ' highest n-number.' - block = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - low(i,j) = 0 - dubbel(i,j) = .FALSE. - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - if (nenter >= i) then - em = 2 + 4*j - if (em < 10) then - 100 continue - if (i <= 9) then + nmax, ')' + endif + read (*, *, err=95) nenter + nenter = max(nenter,1) + nenter = min(nenter,nmax) + write (logfil, *) nenter, ' highest n-number.' + block = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + low(i,j) = 0 + dubbel(i,j) = .FALSE. + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + if (nenter >= i) then + em = 2 + 4*j + if (em < 10) then + 100 continue + if (i <= 9) then write (*, 200) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 202) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (*, *, err=100) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 100 - else - 101 continue - if (i < 10) then + '? (0..', em, ')' + endif + read (*, *, err=100) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 100 + else + 101 continue + if (i < 10) then write (*, 201) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 203) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (*, *, err=101) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 101 - endif + '? (0..', em, ')' + endif + read (*, *, err=101) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 101 + endif write (logfil, *) org(i,j), ' number of electrons in', i, orb& - (j) - if (all) then - lock(i,j) = .FALSE. - else - if (org(i,j) > 1) then - if (org(i,j) <= 10) then + (j) + if (all) then + lock(i,j) = .FALSE. + else + if (org(i,j) > 1) then + if (org(i,j) <= 10) then write (*, 201) & 'Inactive, active or minimum? (i/*/0..', org(i,j)& - - 1, ')' - else + - 1, ')' + else write (*, 202) & 'Inactive, active or minimum? (i/*/0..', org(i,j)& - - 1, ')' - endif - read (*, 1000) y - else if (org(i,j) == 1) then - write (*, 201) 'Inactive or active? (i/*)' - read (*, 1000) y - else + - 1, ')' + endif + read (*, 1000) y + else if (org(i,j) == 1) then + write (*, 201) 'Inactive or active? (i/*)' + read (*, 1000) y + else write (*, 400) 'Inactive, active or doubled ', & - 'excited? (i/*/d)' - read (*, 1000) y - dubbel(i,j) = y(1:1)=='d' .or. y(1:1)=='D' - endif - lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' - if (y(1:1)>='0' .and. y(1:1)<='9') then - if (org(i,j) > 0) then - tmp = ichar(y(1:1)) - ichar('0') + 'excited? (i/*/d)' + read (*, 1000) y + dubbel(i,j) = y(1:1)=='d' .or. y(1:1)=='D' + endif + lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' + if (y(1:1)>='0' .and. y(1:1)<='9') then + if (org(i,j) > 0) then + tmp = ichar(y(1:1)) - ichar('0') if (y(2:2)>='1' .and. y(2:2)<='9') tmp = tmp*10 + & - ichar(y(2:2)) - ichar('0') - low(i,j) = min(org(i,j),tmp) - endif - endif - write (logfil, 1000) y, ' inactive, active, etc...' - endif - if (.not.lock(i,j)) anela = anela + org(i,j) - anel = anel + org(i,j) - par = mod(par + j*org(i,j),2) - else if (all) then - org(i,j) = 0 - lock(i,j) = .FALSE. - else - org(i,j) = 0 - closed(i,j) = .FALSE. - if (i < 10) then + ichar(y(2:2)) - ichar('0') + low(i,j) = min(org(i,j),tmp) + endif + endif + write (logfil, 1000) y, ' inactive, active, etc...' + endif + if (.not.lock(i,j)) anela = anela + org(i,j) + anel = anel + org(i,j) + par = mod(par + j*org(i,j),2) + else if (all) then + org(i,j) = 0 + lock(i,j) = .FALSE. + else + org(i,j) = 0 + closed(i,j) = .FALSE. + if (i < 10) then write (*, 204) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - else + 'doubled excited? (i/*/d)' + else write (*, 205) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - endif - read (*, 1000) x - dubbel(i,j) = x=='d' .or. x=='D' - lock(i,j) = x=='i' .or. x=='I' - write (logfil, *) x, i, orb(j), ' inactive, active, etc...' - endif - else - org(i,j) = 0 - lock(i,j) = .TRUE. - if (closed(i,j)) then - if (i < 10) then - write (*, 204) i, orb(j), ' is a closed shell.' - else - write (*, 205) i, orb(j), ' is a closed shell.' - endif - em = 2 + 4*j - anel = anel + em - block = block + em - endif - endif - anelb = anelb + low(i,j) - end do - lim(i) = lim(i) - block - lim(i) = max0(0,lim(i)) - end do - if (anel /= anel0) then - if (anel0 < 10) then + 'doubled excited? (i/*/d)' + endif + read (*, 1000) x + dubbel(i,j) = x=='d' .or. x=='D' + lock(i,j) = x=='i' .or. x=='I' + write (logfil, *) x, i, orb(j), ' inactive, active, etc...' + endif + else + org(i,j) = 0 + lock(i,j) = .TRUE. + if (closed(i,j)) then + if (i < 10) then + write (*, 204) i, orb(j), ' is a closed shell.' + else + write (*, 205) i, orb(j), ' is a closed shell.' + endif + em = 2 + 4*j + anel = anel + em + block = block + em + endif + endif + anelb = anelb + low(i,j) + end do + lim(i) = lim(i) - block + lim(i) = max0(0,lim(i)) + end do + if (anel /= anel0) then + if (anel0 < 10) then write (*, 300) 'Wrong number of electrons. The first list had ', & - anel0, ' electrons.' - else + anel0, ' electrons.' + else write (*, 301) 'Wrong number of electrons. The first list had ', & - anel0, ' electrons.' - endif - if (anel < 10) then - write (*, 300) 'This list has ', anel, ' electrons.' - else - write (*, 301) 'This list has ', anel, ' electrons.' - endif - second = .FALSE. - go to 40 - endif - 1100 continue + anel0, ' electrons.' + endif + if (anel < 10) then + write (*, 300) 'This list has ', anel, ' electrons.' + else + write (*, 301) 'This list has ', anel, ' electrons.' + endif + second = .FALSE. + go to 40 + endif + 1100 continue write (*, 400) 'Resulting 2*J-number? lower, higher ', & - '(J=1 -> 2*J=2 etc.)' - read (*, *, err=1100) minj, maxj - if (anel == 2*(anel/2)) then - if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be even' - go to 1100 - endif - else - if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be odd' - go to 1100 - endif - endif - write (logfil, *) minj, ' to', maxj, ' is the resulting term.' + '(J=1 -> 2*J=2 etc.)' + read (*, *, err=1100) minj, maxj + if (anel == 2*(anel/2)) then + if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be even' + go to 1100 + endif + else + if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be odd' + go to 1100 + endif + endif + write (logfil, *) minj, ' to', maxj, ' is the resulting term.' ! if (par.NE.par0) then ! write(*,200) 'Wrong parity.' ! if (par0.EQ.0) write(*,*) @@ -267,30 +267,30 @@ subroutine matbin(org, lock, closed, varmax, skal, second, anel0, par0, & ! second = .FALSE. ! goto 40 ! endif - par0 = par - anelb = anela - anelb - 1200 continue - if (anelb < 10) then - write (*, 200) 'Number of excitations = ? (0..', anelb, ')' - read (*, *, err=1200) varmax - else - write (*, 202) 'Number of excitations = ? (0..', anelb, ')' - read (*, *, err=1200) varmax - endif - write (logfil, *) varmax, ' number of excitations.' - 200 format(' ',a,i1,a,a,i1,a) - 201 format(' ',a,i1,a,a,i2,a) - 202 format(' ',a,i2,a,a,i1,a) - 203 format(' ',a,i2,a,a,i2,a) - 204 format(' ',i1,3a) - 205 format(' ',i2,3a) - 208 format(' ',a,i1,a,i2,a) - 300 format(' ',a,i1,a) - 301 format(' ',a,i2,a) - 400 format(' ',3a) - 401 format(' ',2a,i1,a) - 402 format(' ',2a,i2,a) - 1000 format(a,a,a) - 2000 format(i1,a) - return - end subroutine matbin + par0 = par + anelb = anela - anelb + 1200 continue + if (anelb < 10) then + write (*, 200) 'Number of excitations = ? (0..', anelb, ')' + read (*, *, err=1200) varmax + else + write (*, 202) 'Number of excitations = ? (0..', anelb, ')' + read (*, *, err=1200) varmax + endif + write (logfil, *) varmax, ' number of excitations.' + 200 format(' ',a,i1,a,a,i1,a) + 201 format(' ',a,i1,a,a,i2,a) + 202 format(' ',a,i2,a,a,i1,a) + 203 format(' ',a,i2,a,a,i2,a) + 204 format(' ',i1,3a) + 205 format(' ',i2,3a) + 208 format(' ',a,i1,a,i2,a) + 300 format(' ',a,i1,a) + 301 format(' ',a,i2,a) + 400 format(' ',3a) + 401 format(' ',2a,i1,a) + 402 format(' ',2a,i2,a) + 1000 format(a,a,a) + 2000 format(i1,a) + return + end subroutine matbin diff --git a/src/appl/jjgen90/matbin_I.f90 b/src/appl/jjgen90/matbin_I.f90 index 7cfa8d000..399d48209 100644 --- a/src/appl/jjgen90/matbin_I.f90 +++ b/src/appl/jjgen90/matbin_I.f90 @@ -1,23 +1,23 @@ - MODULE matbin_I + MODULE matbin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE matbin (ORG, LOCK, CLOSED, VARMAX, SKAL, SECOND, ANEL0, PAR0& - , LOW, NMAX, LIM, DUBBEL, MINJ, MAXJ) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - logical, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK - logical, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED - integer, INTENT(IN) :: VARMAX - integer, INTENT(OUT) :: SKAL - logical, INTENT(INOUT) :: SECOND - integer, INTENT(IN) :: ANEL0 - integer, INTENT(OUT) :: PAR0 - integer, DIMENSION(15,0:10), INTENT(INOUT) :: LOW - integer, INTENT(OUT) :: NMAX - integer, DIMENSION(15), INTENT(INOUT) :: LIM - logical, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ + , LOW, NMAX, LIM, DUBBEL, MINJ, MAXJ) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + logical, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK + logical, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED + integer, INTENT(IN) :: VARMAX + integer, INTENT(OUT) :: SKAL + logical, INTENT(INOUT) :: SECOND + integer, INTENT(IN) :: ANEL0 + integer, INTENT(OUT) :: PAR0 + integer, DIMENSION(15,0:10), INTENT(INOUT) :: LOW + integer, INTENT(OUT) :: NMAX + integer, DIMENSION(15), INTENT(INOUT) :: LIM + logical, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/matcin.f90 b/src/appl/jjgen90/matcin.f90 index 8e06d3784..0376e4b24 100644 --- a/src/appl/jjgen90/matcin.f90 +++ b/src/appl/jjgen90/matcin.f90 @@ -1,188 +1,188 @@ ! last edited July 31, 1996 subroutine matcin(lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim& - ) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + ) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer :: cfmax - integer :: nmax - integer :: minj - integer :: maxj - integer :: lim(15) - logical , intent(out) :: lock(15,0:10) - logical , intent(in) :: closed(15,0:10) - logical , intent(in) :: med(15,0:10) + integer :: varmax + integer :: cfmax + integer :: nmax + integer :: minj + integer :: maxj + integer :: lim(15) + logical , intent(out) :: lock(15,0:10) + logical , intent(in) :: closed(15,0:10) + logical , intent(in) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, lmax, nmaks, mshell, lmaks, j - logical :: all, lima - character :: x - character, dimension(0:10) :: orb + integer :: i, lmax, nmaks, mshell, lmaks, j + logical :: all, lima + character :: x + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - nmaks = 1 - lmaks = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - if (.not.med(i,j)) cycle - nmaks = i - lmaks = max(j,lmaks) - end do - end do - 60 continue - if (nmaks <= 9) then - write (*, 201) 'Highest n-number? (', nmaks, '..15)' - else - write (*, 202) 'Highest n-number? (', nmaks, '..15)' - endif - read (*, *, err=60) nmax - nmax = max(nmax,nmaks) - nmax = min(nmax,15) - write (logfil, *) nmax, ' Highest principal quantum number.' + 'n'/ + nmaks = 1 + lmaks = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + if (.not.med(i,j)) cycle + nmaks = i + lmaks = max(j,lmaks) + end do + end do + 60 continue + if (nmaks <= 9) then + write (*, 201) 'Highest n-number? (', nmaks, '..15)' + else + write (*, 202) 'Highest n-number? (', nmaks, '..15)' + endif + read (*, *, err=60) nmax + nmax = max(nmax,nmaks) + nmax = min(nmax,15) + write (logfil, *) nmax, ' Highest principal quantum number.' write (*, 400) 'Highest l-number? (', orb(lmaks), '..', orb(min(10,nmax-1& - )), ')' - read (*, 1000) x - lmax = -1 - do i = 0, min(10,nmax - 1) - if (x /= orb(i)) cycle - lmax = i - end do - lmax = max(lmaks,lmax) + )), ')' + read (*, 1000) x + lmax = -1 + do i = 0, min(10,nmax - 1) + if (x /= orb(i)) cycle + lmax = i + end do + lmax = max(lmaks,lmax) ! if (lmax.EQ.-1) goto 70 - write (logfil, *) lmax, ' Highest orbital angular momentum.' - write (*, 200) 'Are all these nl-subshells active? (n/*)' - read (*, 1000) x - all = .not.(x=='n' .or. x=='N') - write (logfil, *) all, ' all subshells active.' - lim = 0 - if (nmax >= 2) then + write (logfil, *) lmax, ' Highest orbital angular momentum.' + write (*, 200) 'Are all these nl-subshells active? (n/*)' + read (*, 1000) x + all = .not.(x=='n' .or. x=='N') + write (logfil, *) all, ' all subshells active.' + lim = 0 + if (nmax >= 2) then !******************* modified by yu zou, 3/6/00 ! this option cannot run correctly. It is not provided at present. - lima = .FALSE. + lima = .FALSE. !******************* modified by yu zou, 3/6/00 - write (logfil, *) lima, ' limitations on population of n-subshells.' - if (lima) then - mshell = 0 - do i = 1, nmax - 1 - mshell = mshell + 2*i*i - 83 continue - if (i == 1) then - write (*, 200) 'Minimum number of electrons with n=1? (0..2)' - else if (i < 10) then - if (mshell < 100) then + write (logfil, *) lima, ' limitations on population of n-subshells.' + if (lima) then + mshell = 0 + do i = 1, nmax - 1 + mshell = mshell + 2*i*i + 83 continue + if (i == 1) then + write (*, 200) 'Minimum number of electrons with n=1? (0..2)' + else if (i < 10) then + if (mshell < 100) then write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..', mshell, ')' - else + '? (0..', mshell, ')' + else write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - else + '? (0..)' + endif + else write (*, 202) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - read (*, *, err=83) lim(i) - lim(i) = min0(mshell,lim(i)) + '? (0..)' + endif + read (*, *, err=83) lim(i) + lim(i) = min0(mshell,lim(i)) write (logfil, *) lim(i), & - ' is minimum number of electrons with n =', i - end do - endif - endif - if (all) then - do i = 1, 15 - if (i < 10) then - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - lock(i,j) = .FALSE. - else - lock(i,j) = .TRUE. + ' is minimum number of electrons with n =', i + end do + endif + endif + if (all) then + do i = 1, 15 + if (i < 10) then + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + lock(i,j) = .FALSE. + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 204) i, orb(j), & - ' is a closed shell.' - endif - end do - else - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - lock(i,j) = .FALSE. - else - lock(i,j) = .TRUE. + ' is a closed shell.' + endif + end do + else + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + lock(i,j) = .FALSE. + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 205) i, orb(j), & - ' is a closed shell.' - endif - end do - endif - end do - else - do i = 1, 15 - if (i < 10) then - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - write (*, 204) i, orb(j), ' inactive or active? ', '(i/*)' - read (*, 1000) x + ' is a closed shell.' + endif + end do + endif + end do + else + do i = 1, 15 + if (i < 10) then + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + write (*, 204) i, orb(j), ' inactive or active? ', '(i/*)' + read (*, 1000) x write (logfil, *) x, i, orb(j), & - ' inactive, active, etc...' - lock(i,j) = x=='i' .or. x=='I' - else - lock(i,j) = .TRUE. + ' inactive, active, etc...' + lock(i,j) = x=='i' .or. x=='I' + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 204) i, orb(j), & - ' is a closed shell.' - endif - end do - else - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - write (*, 205) i, orb(j), ' inactive or active? ', '(i/*)' - read (*, 1000) x + ' is a closed shell.' + endif + end do + else + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + write (*, 205) i, orb(j), ' inactive or active? ', '(i/*)' + read (*, 1000) x write (logfil, *) x, i, orb(j), & - ' inactive, active, etc...' - lock(i,j) = x=='i' .or. x=='I' - else - lock(i,j) = .TRUE. + ' inactive, active, etc...' + lock(i,j) = x=='i' .or. x=='I' + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 205) i, orb(j), & - ' is a closed shell.' - endif - end do - endif - end do - endif - 1100 continue + ' is a closed shell.' + endif + end do + endif + end do + endif + 1100 continue write (*, 400) 'Resulting 2*J-number? lower, higher ', & - '(J=1 -> 2*J=2 etc.)' - read (*, *, err=1100) minj, maxj - write (logfil, *) minj, ' to', maxj, ' is the resulting term.' - 160 continue - write (*, 200) 'Number of excitations = ? (0..)' - read (*, *, err=160) varmax - write (logfil, *) varmax, ' number of excitations.' - 170 continue + '(J=1 -> 2*J=2 etc.)' + read (*, *, err=1100) minj, maxj + write (logfil, *) minj, ' to', maxj, ' is the resulting term.' + 160 continue + write (*, 200) 'Number of excitations = ? (0..)' + read (*, *, err=160) varmax + write (logfil, *) varmax, ' number of excitations.' + 170 continue write (*, 400) 'Maximum number of uncoupled configuration', & - ' states? (0..)' - read (*, *, err=170) cfmax - write (logfil, *) cfmax, ' maximum number ' - write (*, *) - - 200 format(' ',a,i1,a,a,i1,a) - 201 format(' ',a,i1,a,a,i2,a) - 202 format(' ',a,i2,a,a,i1,a) - 203 format(' ',a,i2,a,a,i2,a) - 204 format(' ',i1,3a) - 205 format(' ',i2,3a) - 208 format(' ',a,i1,a,i2,a) - 300 format(' ',a,i1,a) - 301 format(' ',a,i2,a) - 400 format(' ',7a) - 401 format(' ',2a,i1,a) - 402 format(' ',2a,i2,a) - 1000 format(a,a,a) - 2000 format(i1,a) - return - end subroutine matcin + ' states? (0..)' + read (*, *, err=170) cfmax + write (logfil, *) cfmax, ' maximum number ' + write (*, *) + + 200 format(' ',a,i1,a,a,i1,a) + 201 format(' ',a,i1,a,a,i2,a) + 202 format(' ',a,i2,a,a,i1,a) + 203 format(' ',a,i2,a,a,i2,a) + 204 format(' ',i1,3a) + 205 format(' ',i2,3a) + 208 format(' ',a,i1,a,i2,a) + 300 format(' ',a,i1,a) + 301 format(' ',a,i2,a) + 400 format(' ',7a) + 401 format(' ',2a,i1,a) + 402 format(' ',2a,i2,a) + 1000 format(a,a,a) + 2000 format(i1,a) + return + end subroutine matcin diff --git a/src/appl/jjgen90/matcin_I.f90 b/src/appl/jjgen90/matcin_I.f90 index 4527e2574..089866552 100644 --- a/src/appl/jjgen90/matcin_I.f90 +++ b/src/appl/jjgen90/matcin_I.f90 @@ -1,18 +1,18 @@ - MODULE matcin_I + MODULE matcin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE matcin (LOCK, CLOSED, MED, VARMAX, CFMAX, NMAX, MINJ, MAXJ& - , LIM) - logical, DIMENSION(15,0:10), INTENT(OUT) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - logical, DIMENSION(15,0:10), INTENT(IN) :: MED - integer, INTENT(IN) :: VARMAX - integer, INTENT(IN) :: CFMAX - integer, INTENT(OUT) :: NMAX - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ - integer, DIMENSION(15), INTENT(INOUT) :: LIM + , LIM) + logical, DIMENSION(15,0:10), INTENT(OUT) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + logical, DIMENSION(15,0:10), INTENT(IN) :: MED + integer, INTENT(IN) :: VARMAX + integer, INTENT(IN) :: CFMAX + integer, INTENT(OUT) :: NMAX + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ + integer, DIMENSION(15), INTENT(INOUT) :: LIM !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/merge.f90 b/src/appl/jjgen90/merge.f90 index 0761fd8bc..08e62065a 100644 --- a/src/appl/jjgen90/merge.f90 +++ b/src/appl/jjgen90/merge.f90 @@ -1,176 +1,176 @@ ! last edited July 31, 1996 - subroutine merge(single, posn, posl, ii) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine merge(single, posn, posl, ii) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use lika_I - use fivefirst_I - use lasa1_I - use test_I - use lasa2_I + use lika_I + use fivefirst_I + use lasa1_I + use test_I + use lasa2_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: ii - logical , intent(in) :: single - integer :: posn(110) - integer :: posl(110) + integer , intent(in) :: ii + logical , intent(in) :: single + integer :: posn(110) + integer :: posl(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 - integer, parameter :: utfil = 9 - integer, parameter :: nyfil = 13 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 + integer, parameter :: utfil = 9 + integer, parameter :: nyfil = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop1, pop2 - integer :: skal1, skal2, i, j, k, cf, stopp1, stopp2 - integer , dimension(15,0:10,0:1) :: popo - integer :: ii1 - logical :: p1, p2, slut1, slut2 + integer , dimension(15,0:10,0:1) :: pop1, pop2 + integer :: skal1, skal2, i, j, k, cf, stopp1, stopp2 + integer , dimension(15,0:10,0:1) :: popo + integer :: ii1 + logical :: p1, p2, slut1, slut2 character :: rad11*200, rad12*200, rad21*200, rad22*200, rad31*200, rad32& - *200 + *200 !----------------------------------------------- - - ii1 = mod(ii,2) - if (ii1 == 0) then - open(unit=utfil, file='clist.out', status='unknown', position='asis') - else - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - endif - open(unit=nyfil, file='clist.new', status='unknown', position='asis') - slut1 = .FALSE. - slut2 = single - cf = 0 - call fivefirst (slut1, slut2, posn, posl) - skal1 = 20 - skal2 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - 10 continue - if (.not.slut1 .and. .not.slut2) then - call test (p1, p2, pop1, pop2, 15) - if (p1) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) - end do - stopp1 = max(1,9*skal1) - stopp2 = 9*skal1 + 2 - 30 continue - call lasa2 (fil_1, rad21, rad31, stopp1, slut1) - if (.not.slut1) then - write (utfil, 999) rad11(1:stopp1) - write (utfil, 999) rad21(1:stopp1) - write (utfil, 999) rad31(1:stopp2) - cf = cf + 1 - endif - skal1 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - if (.not.slut1) then - if (lika(popo,pop1)) go to 30 - endif - if (p2) then - 40 continue - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) then - if (lika(popo,pop2)) go to 40 - endif - endif - go to 10 - else if (p2) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) - end do - stopp1 = max(1,9*skal2) - stopp2 = 9*skal2 + 2 - 60 continue - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - if (.not.slut2) then - write (utfil, 999) rad12(1:stopp1) - write (utfil, 999) rad22(1:stopp1) - write (utfil, 999) rad32(1:stopp2) - write (nyfil, 999) rad12(1:stopp1) - write (nyfil, 999) rad22(1:stopp1) - write (nyfil, 999) rad32(1:stopp2) - cf = cf + 1 - endif - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) then - if (lika(popo,pop2)) go to 60 - endif - go to 10 - else - write (*, *) 'fatal error' - stop - endif - else if (.not.slut1 .and. slut2) then - 70 continue - stopp1 = max(1,9*skal1) - stopp2 = 9*skal1 + 2 - call lasa2 (fil_1, rad21, rad31, stopp1, slut1) - if (.not.slut1) then - write (utfil, 999) rad11(1:stopp1) - write (utfil, 999) rad21(1:stopp1) - write (utfil, 999) rad31(1:stopp2) - cf = cf + 1 - endif - skal1 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - if (.not.slut1) go to 70 - else if (slut1 .and. .not.slut2) then - 80 continue - stopp1 = max(1,9*skal2) - stopp2 = 9*skal2 + 2 - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - if (.not.slut2) then - write (utfil, 999) rad12(1:stopp1) - write (utfil, 999) rad22(1:stopp1) - write (utfil, 999) rad32(1:stopp2) - write (nyfil, 999) rad12(1:stopp1) - write (nyfil, 999) rad22(1:stopp1) - write (nyfil, 999) rad32(1:stopp2) - cf = cf + 1 - endif - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) go to 80 - endif - close(fil_1) - close(fil_2) - close(utfil) - close(nyfil) - if (cf == 0) then - write (*, 105) 'No configuration state in the final list.' - else if (cf == 1) then - write (*, 105) 'One configuration state in the final list.' - else if (cf < 10) then - write (*, 101) cf, ' configuration states in the final list.' - else if (cf < 100) then - write (*, 102) cf, ' configuration states in the final list.' - else if (cf < 1000) then - write (*, 103) cf, ' configuration states in the final list.' - else if (cf < 10000) then - write (*, 104) cf, ' configuration states in the final list.' - else if (cf < 100000) then - write (*, 106) cf, ' configuration states in the final list.' - else - write (*, *) cf, ' configuration states in the final list.' - endif - return - 101 format(' ',i1,a) - 102 format(' ',i2,a) - 103 format(' ',i3,a) - 104 format(' ',i4,a) - 105 format(' ',a) - 106 format(' ',i5,a) - 999 format(a) - return - end subroutine merge + + ii1 = mod(ii,2) + if (ii1 == 0) then + open(unit=utfil, file='clist.out', status='unknown', position='asis') + else + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + endif + open(unit=nyfil, file='clist.new', status='unknown', position='asis') + slut1 = .FALSE. + slut2 = single + cf = 0 + call fivefirst (slut1, slut2, posn, posl) + skal1 = 20 + skal2 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + 10 continue + if (.not.slut1 .and. .not.slut2) then + call test (p1, p2, pop1, pop2, 15) + if (p1) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) + end do + stopp1 = max(1,9*skal1) + stopp2 = 9*skal1 + 2 + 30 continue + call lasa2 (fil_1, rad21, rad31, stopp1, slut1) + if (.not.slut1) then + write (utfil, 999) rad11(1:stopp1) + write (utfil, 999) rad21(1:stopp1) + write (utfil, 999) rad31(1:stopp2) + cf = cf + 1 + endif + skal1 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + if (.not.slut1) then + if (lika(popo,pop1)) go to 30 + endif + if (p2) then + 40 continue + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) then + if (lika(popo,pop2)) go to 40 + endif + endif + go to 10 + else if (p2) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) + end do + stopp1 = max(1,9*skal2) + stopp2 = 9*skal2 + 2 + 60 continue + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + if (.not.slut2) then + write (utfil, 999) rad12(1:stopp1) + write (utfil, 999) rad22(1:stopp1) + write (utfil, 999) rad32(1:stopp2) + write (nyfil, 999) rad12(1:stopp1) + write (nyfil, 999) rad22(1:stopp1) + write (nyfil, 999) rad32(1:stopp2) + cf = cf + 1 + endif + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) then + if (lika(popo,pop2)) go to 60 + endif + go to 10 + else + write (*, *) 'fatal error' + stop + endif + else if (.not.slut1 .and. slut2) then + 70 continue + stopp1 = max(1,9*skal1) + stopp2 = 9*skal1 + 2 + call lasa2 (fil_1, rad21, rad31, stopp1, slut1) + if (.not.slut1) then + write (utfil, 999) rad11(1:stopp1) + write (utfil, 999) rad21(1:stopp1) + write (utfil, 999) rad31(1:stopp2) + cf = cf + 1 + endif + skal1 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + if (.not.slut1) go to 70 + else if (slut1 .and. .not.slut2) then + 80 continue + stopp1 = max(1,9*skal2) + stopp2 = 9*skal2 + 2 + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + if (.not.slut2) then + write (utfil, 999) rad12(1:stopp1) + write (utfil, 999) rad22(1:stopp1) + write (utfil, 999) rad32(1:stopp2) + write (nyfil, 999) rad12(1:stopp1) + write (nyfil, 999) rad22(1:stopp1) + write (nyfil, 999) rad32(1:stopp2) + cf = cf + 1 + endif + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) go to 80 + endif + close(fil_1) + close(fil_2) + close(utfil) + close(nyfil) + if (cf == 0) then + write (*, 105) 'No configuration state in the final list.' + else if (cf == 1) then + write (*, 105) 'One configuration state in the final list.' + else if (cf < 10) then + write (*, 101) cf, ' configuration states in the final list.' + else if (cf < 100) then + write (*, 102) cf, ' configuration states in the final list.' + else if (cf < 1000) then + write (*, 103) cf, ' configuration states in the final list.' + else if (cf < 10000) then + write (*, 104) cf, ' configuration states in the final list.' + else if (cf < 100000) then + write (*, 106) cf, ' configuration states in the final list.' + else + write (*, *) cf, ' configuration states in the final list.' + endif + return + 101 format(' ',i1,a) + 102 format(' ',i2,a) + 103 format(' ',i3,a) + 104 format(' ',i4,a) + 105 format(' ',a) + 106 format(' ',i5,a) + 999 format(a) + return + end subroutine merge diff --git a/src/appl/jjgen90/merge_I.f90 b/src/appl/jjgen90/merge_I.f90 index 9b5dcfa0f..d5599f84d 100644 --- a/src/appl/jjgen90/merge_I.f90 +++ b/src/appl/jjgen90/merge_I.f90 @@ -1,11 +1,11 @@ - MODULE merge_I + MODULE merge_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE merge (SINGLE, POSN, POSL, II) - logical, INTENT(IN) :: SINGLE - integer, DIMENSION(110) :: POSN - integer, DIMENSION(110) :: POSL - integer, INTENT(IN) :: II - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE merge (SINGLE, POSN, POSL, II) + logical, INTENT(IN) :: SINGLE + integer, DIMENSION(110) :: POSN + integer, DIMENSION(110) :: POSL + integer, INTENT(IN) :: II + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/mergeb.f90 b/src/appl/jjgen90/mergeb.f90 index e82174593..fe038bc30 100644 --- a/src/appl/jjgen90/mergeb.f90 +++ b/src/appl/jjgen90/mergeb.f90 @@ -1,139 +1,139 @@ ! last edited July 31, 1996 - subroutine mergeb(antal) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine mergeb(antal) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use test_I + use test_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(out) :: antal + integer , intent(out) :: antal !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop1, pop2, popo - integer :: i, j, k - logical :: p1, p2, slut1, slut2 + integer , dimension(15,0:10,0:1) :: pop1, pop2, popo + integer :: i, j, k + logical :: p1, p2, slut1, slut2 !----------------------------------------------- - slut1 = .FALSE. - slut2 = .FALSE. - antal = 0 - open(unit=22, status='scratch', position='asis') - do i = 1, 15 - read (20, 5000, end=2) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=2) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 3 - 2 continue - slut1 = .TRUE. - 3 continue - do i = 1, 15 - read (21, 5000, end=5) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=5) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 6 - 5 continue - slut2 = .TRUE. - 6 continue - 10 continue - if (.not.slut1 .and. .not.slut2) then - call test (p1, p2, pop1, pop2, 15) - if (p1) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) - end do - do i = 1, 15 - write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (20, 5000, end=21) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=21) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 22 - 21 continue - slut1 = .TRUE. - 22 continue - if (p2) then - do i = 1, 15 - read (21, 5000, end=23) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=23) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 10 - 23 continue - slut2 = .TRUE. - endif - else if (p2) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) - end do - if (.not.slut2) then - do i = 1, 15 - write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - endif - do i = 1, 15 - read (21, 5000, end=53) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=53) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 10 - 53 continue - slut2 = .TRUE. - else - write (*, *) 'fatal error' - stop - endif - go to 10 - else if (.not.slut1 .and. slut2) then - 70 continue - do i = 1, 15 - write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (20, 5000, end=71) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=71) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 70 - 71 continue - slut1 = .TRUE. - else if (slut1 .and. .not.slut2) then - 80 continue - do i = 1, 15 - write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (21, 5000, end=81) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=81) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 80 - 81 continue - slut2 = .TRUE. - endif - rewind (22) - close(20) - close(21) - open(unit=20, status='scratch', position='asis') - 580 continue - do i = 1, 15 - read (22, 5000, end=999) (pop2(i,j,0),j=0,min(10,i - 1)) - read (22, 5000, end=999) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - write (20, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (20, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - antal = antal + 1 - go to 580 - 999 continue - close(22) - rewind (20) - return - 5000 format(11i2) - return - end subroutine mergeb + slut1 = .FALSE. + slut2 = .FALSE. + antal = 0 + open(unit=22, status='scratch', position='asis') + do i = 1, 15 + read (20, 5000, end=2) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=2) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 3 + 2 continue + slut1 = .TRUE. + 3 continue + do i = 1, 15 + read (21, 5000, end=5) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=5) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 6 + 5 continue + slut2 = .TRUE. + 6 continue + 10 continue + if (.not.slut1 .and. .not.slut2) then + call test (p1, p2, pop1, pop2, 15) + if (p1) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) + end do + do i = 1, 15 + write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (20, 5000, end=21) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=21) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 22 + 21 continue + slut1 = .TRUE. + 22 continue + if (p2) then + do i = 1, 15 + read (21, 5000, end=23) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=23) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 10 + 23 continue + slut2 = .TRUE. + endif + else if (p2) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) + end do + if (.not.slut2) then + do i = 1, 15 + write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + endif + do i = 1, 15 + read (21, 5000, end=53) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=53) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 10 + 53 continue + slut2 = .TRUE. + else + write (*, *) 'fatal error' + stop + endif + go to 10 + else if (.not.slut1 .and. slut2) then + 70 continue + do i = 1, 15 + write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (20, 5000, end=71) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=71) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 70 + 71 continue + slut1 = .TRUE. + else if (slut1 .and. .not.slut2) then + 80 continue + do i = 1, 15 + write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (21, 5000, end=81) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=81) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 80 + 81 continue + slut2 = .TRUE. + endif + rewind (22) + close(20) + close(21) + open(unit=20, status='scratch', position='asis') + 580 continue + do i = 1, 15 + read (22, 5000, end=999) (pop2(i,j,0),j=0,min(10,i - 1)) + read (22, 5000, end=999) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + write (20, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (20, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + antal = antal + 1 + go to 580 + 999 continue + close(22) + rewind (20) + return + 5000 format(11i2) + return + end subroutine mergeb diff --git a/src/appl/jjgen90/mergeb_I.f90 b/src/appl/jjgen90/mergeb_I.f90 index 1a2b19353..d756de55d 100644 --- a/src/appl/jjgen90/mergeb_I.f90 +++ b/src/appl/jjgen90/mergeb_I.f90 @@ -1,8 +1,8 @@ - MODULE mergeb_I + MODULE mergeb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE mergeb (ANTAL) - integer, INTENT(OUT) :: ANTAL - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE mergeb (ANTAL) + integer, INTENT(OUT) :: ANTAL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/open79.f90 b/src/appl/jjgen90/open79.f90 index 2b47dbc40..cf6d69617 100644 --- a/src/appl/jjgen90/open79.f90 +++ b/src/appl/jjgen90/open79.f90 @@ -1,30 +1,30 @@ - subroutine open79(i) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine open79(i) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i + integer , intent(in) :: i !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: utfil = 9 + integer, parameter :: fil_1 = 7 + integer, parameter :: utfil = 9 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i1 + integer :: i1 !----------------------------------------------- - i1 = mod(i,2) - if (i1 == 0) then - open(fil_1, file='fil1.dat', status='unknown', position='asis') - open(unit=utfil, file='clist.out', status='unknown', position='asis') - else - open(fil_1, file='clist.out', status='unknown', position='asis') - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - endif - close(utfil) - rewind (fil_1) - return - end subroutine open79 + i1 = mod(i,2) + if (i1 == 0) then + open(fil_1, file='fil1.dat', status='unknown', position='asis') + open(unit=utfil, file='clist.out', status='unknown', position='asis') + else + open(fil_1, file='clist.out', status='unknown', position='asis') + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + endif + close(utfil) + rewind (fil_1) + return + end subroutine open79 diff --git a/src/appl/jjgen90/open79_I.f90 b/src/appl/jjgen90/open79_I.f90 index 564bee571..25852059f 100644 --- a/src/appl/jjgen90/open79_I.f90 +++ b/src/appl/jjgen90/open79_I.f90 @@ -1,9 +1,9 @@ - MODULE open79_I + MODULE open79_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE open79 (I) - integer, INTENT(IN) :: I +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE open79 (I) + integer, INTENT(IN) :: I !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/reada.f90 b/src/appl/jjgen90/reada.f90 index 6ec3bc655..fab00ecfd 100644 --- a/src/appl/jjgen90/reada.f90 +++ b/src/appl/jjgen90/reada.f90 @@ -1,75 +1,75 @@ ! last edited July 31, 1996 - subroutine reada(rad1, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reada(rad1, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: skal - logical , intent(out) :: slut - character , intent(in) :: rad1*200 - integer , intent(out) :: pop(15,0:10,0:1) + integer , intent(inout) :: skal + logical , intent(out) :: slut + character , intent(in) :: rad1*200 + integer , intent(out) :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k, n, l, antal, stopp - character, dimension(0:10) :: orb + integer :: i, j, k, n, l, antal, stopp + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - slut = .FALSE. - do n = 1, 15 - pop(n,:min(10,n-1),:1) = 0 - end do - stopp = skal - 1 - l10: do i = 0, stopp - j = 9*i - if (rad1(j+3:j+3) == ' ') return - skal = i + 1 - slut = .TRUE. - n = ichar(rad1(j+3:j+3)) - ichar('0') - if (rad1(j+2:j+2) == '1') n = n + 10 - if (n<=15 .and. n>=1) then - if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 0 - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - else - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - endif - else - slut = .TRUE. - return - endif - end do l10 - return - end subroutine reada + 'n'/ + slut = .FALSE. + do n = 1, 15 + pop(n,:min(10,n-1),:1) = 0 + end do + stopp = skal - 1 + l10: do i = 0, stopp + j = 9*i + if (rad1(j+3:j+3) == ' ') return + skal = i + 1 + slut = .TRUE. + n = ichar(rad1(j+3:j+3)) - ichar('0') + if (rad1(j+2:j+2) == '1') n = n + 10 + if (n<=15 .and. n>=1) then + if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 0 + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + else + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + endif + else + slut = .TRUE. + return + endif + end do l10 + return + end subroutine reada diff --git a/src/appl/jjgen90/reada_I.f90 b/src/appl/jjgen90/reada_I.f90 index cf2b06529..c678575ac 100644 --- a/src/appl/jjgen90/reada_I.f90 +++ b/src/appl/jjgen90/reada_I.f90 @@ -1,11 +1,11 @@ - MODULE reada_I + MODULE reada_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE reada (RAD1, POP, SKAL, SLUT) - character (LEN = 200), INTENT(IN) :: RAD1 - integer, DIMENSION(15,0:10,0:1), INTENT(OUT) :: POP - integer, INTENT(INOUT) :: SKAL - logical, INTENT(OUT) :: SLUT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE reada (RAD1, POP, SKAL, SLUT) + character (LEN = 200), INTENT(IN) :: RAD1 + integer, DIMENSION(15,0:10,0:1), INTENT(OUT) :: POP + integer, INTENT(INOUT) :: SKAL + logical, INTENT(OUT) :: SLUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/reffa.f90 b/src/appl/jjgen90/reffa.f90 index 76cc148c1..840e1212b 100644 --- a/src/appl/jjgen90/reffa.f90 +++ b/src/appl/jjgen90/reffa.f90 @@ -1,130 +1,130 @@ ! last edited July 31, 1996 - subroutine reffa(posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reffa(posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: posn(110) - integer , intent(inout) :: posl(110) + integer , intent(inout) :: posn(110) + integer , intent(inout) :: posl(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 - integer, parameter :: reffil = 18 + integer, parameter :: logfil = 31 + integer, parameter :: reffil = 18 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: stat - integer :: i, n, l, num - logical :: ok - character , dimension(0:10) :: orb - character :: m, x, y + integer , dimension(15,0:10) :: stat + integer :: i, n, l, num + logical :: ok + character , dimension(0:10) :: orb + character :: m, x, y !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - - do n = 1, 15 - stat(n,:min(n-1,10)) = 0 - end do + 'n'/ + + do n = 1, 15 + stat(n,:min(n-1,10)) = 0 + end do write (*, 200) 'Default, reverse, symmetry or user specified ordering?', & - ' (*/r/s/u)' - read (*, 1000) x - if (x=='u' .or. x=='U') then - write (logfil, *) 'User specified ordering.' - inquire(file='clist.ref', exist=ok) + ' (*/r/s/u)' + read (*, 1000) x + if (x=='u' .or. x=='U') then + write (logfil, *) 'User specified ordering.' + inquire(file='clist.ref', exist=ok) if (ok) open(unit=reffil, status='old', file='clist.ref', position=& - 'asis') - l = -1 - num = 1 - if (.not.ok) then + 'asis') + l = -1 + num = 1 + if (.not.ok) then write (*, 200) 'No reference file present! ', & - 'The couplings will appear in standard order.' - else - write (*, 200) 'Reference file present!' - 20 continue - read (reffil, 1000, end=40) m, x, y - n = ichar(m) - ichar('0') - if (x>='0' .and. x<='9') then - n = n*10 + ichar(x) - ichar('0') - x = y - endif - do i = 0, 10 - if (orb(i) /= x) cycle - l = i - end do - if (l==(-1) .or. n<0 .or. n>15 .or. n<=l .or. l>10) go to 40 - if (stat(n,l) /= 0) then - write (*, 200) 'The same orbital appeared more than once!' - l = -1 - go to 20 - endif - posn(num) = n - posl(num) = l - stat(n,l) = num - num = num + 1 - l = -1 - go to 20 - 40 continue - if (num == 1) then + 'The couplings will appear in standard order.' + else + write (*, 200) 'Reference file present!' + 20 continue + read (reffil, 1000, end=40) m, x, y + n = ichar(m) - ichar('0') + if (x>='0' .and. x<='9') then + n = n*10 + ichar(x) - ichar('0') + x = y + endif + do i = 0, 10 + if (orb(i) /= x) cycle + l = i + end do + if (l==(-1) .or. n<0 .or. n>15 .or. n<=l .or. l>10) go to 40 + if (stat(n,l) /= 0) then + write (*, 200) 'The same orbital appeared more than once!' + l = -1 + go to 20 + endif + posn(num) = n + posl(num) = l + stat(n,l) = num + num = num + 1 + l = -1 + go to 20 + 40 continue + if (num == 1) then write (*, 200) 'The program failed reading the order of ', & - 'the customized coupling scheme.' - else + 'the customized coupling scheme.' + else write (*, 200) 'The couplings will ', & - 'be made in the following customized order:' - if (num == 2) then - write (*, 100) posn(1), orb(posl(1)) - else + 'be made in the following customized order:' + if (num == 2) then + write (*, 100) posn(1), orb(posl(1)) + else write (*, 100) posn(1), orb(posl(1)), (',',posn(i),orb(posl(i& - )),i=2,num - 1) - endif - endif - endif - do n = 1, 15 - do l = 0, min(n - 1,10) - if (stat(n,l) /= 0) cycle - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - close(reffil) - write (*, 200) - else if (x=='s' .or. x=='S') then - write (logfil, *) 'Symmetry ordering.' - num = 1 - do l = 0, 10 - do n = l + 1, 15 - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - else if (x=='r' .or. x=='R') then - write (logfil, *) 'Reverse ordering.' - num = 1 - do n = 15, 1, -1 - do l = min(n - 1,10), 0, -1 - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - else - write (logfil, *) 'Standard ordering.' - num = 1 - do n = 1, 15 - do l = 0, min(n - 1,10) - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - endif - return - 100 format(' ',110(i2,a,a)) - 200 format(' ',2a) - 1000 format(3a) - return - end subroutine reffa + )),i=2,num - 1) + endif + endif + endif + do n = 1, 15 + do l = 0, min(n - 1,10) + if (stat(n,l) /= 0) cycle + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + close(reffil) + write (*, 200) + else if (x=='s' .or. x=='S') then + write (logfil, *) 'Symmetry ordering.' + num = 1 + do l = 0, 10 + do n = l + 1, 15 + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + else if (x=='r' .or. x=='R') then + write (logfil, *) 'Reverse ordering.' + num = 1 + do n = 15, 1, -1 + do l = min(n - 1,10), 0, -1 + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + else + write (logfil, *) 'Standard ordering.' + num = 1 + do n = 1, 15 + do l = 0, min(n - 1,10) + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + endif + return + 100 format(' ',110(i2,a,a)) + 200 format(' ',2a) + 1000 format(3a) + return + end subroutine reffa diff --git a/src/appl/jjgen90/reffa_I.f90 b/src/appl/jjgen90/reffa_I.f90 index ab2b1c8b5..befde9066 100644 --- a/src/appl/jjgen90/reffa_I.f90 +++ b/src/appl/jjgen90/reffa_I.f90 @@ -1,10 +1,10 @@ - MODULE reffa_I + MODULE reffa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE reffa (POSN, POSL) - integer, DIMENSION(110), INTENT(INOUT) :: POSN - integer, DIMENSION(110), INTENT(INOUT) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE reffa (POSN, POSL) + integer, DIMENSION(110), INTENT(INOUT) :: POSN + integer, DIMENSION(110), INTENT(INOUT) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/slug.f90 b/src/appl/jjgen90/slug.f90 index b7a531c43..919cdfb4c 100644 --- a/src/appl/jjgen90/slug.f90 +++ b/src/appl/jjgen90/slug.f90 @@ -1,65 +1,65 @@ - + ! last edited November 2, 1995 subroutine slug(i, j, varmax, varupp, varned, ansats, org, lock, dubbel, & - low, start, stopp) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + low, start, stopp) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i - integer , intent(in) :: j - integer , intent(in) :: varmax - integer , intent(out) :: start - integer , intent(out) :: stopp - logical , intent(in) :: lock - integer , intent(inout) :: varupp(15,0:10) - integer , intent(inout) :: varned(15,0:10) - integer , intent(in) :: ansats(15,0:10,0:1) - integer , intent(in) :: org(15,0:10) - integer , intent(in) :: low(15,0:10) - logical , intent(in) :: dubbel(15,0:10) + integer , intent(in) :: i + integer , intent(in) :: j + integer , intent(in) :: varmax + integer , intent(out) :: start + integer , intent(out) :: stopp + logical , intent(in) :: lock + integer , intent(inout) :: varupp(15,0:10) + integer , intent(inout) :: varned(15,0:10) + integer , intent(in) :: ansats(15,0:10,0:1) + integer , intent(in) :: org(15,0:10) + integer , intent(in) :: low(15,0:10) + logical , intent(in) :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: minmax, iold, jold + integer :: minmax, iold, jold !----------------------------------------------- - if (i == 1) then - varupp(1,0) = 0 - varned(1,0) = 0 - else - if (j == 0) then - iold = i - 1 - jold = min(10,iold - 1) - else - iold = i - jold = j - 1 - endif - if (jold == 0) then + if (i == 1) then + varupp(1,0) = 0 + varned(1,0) = 0 + else + if (j == 0) then + iold = i - 1 + jold = min(10,iold - 1) + else + iold = i + jold = j - 1 + endif + if (jold == 0) then varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)-org(& - iold,jold)) + iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)) - else + jold,0)) + else varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)+ansats(& - iold,jold,1)-org(iold,jold)) + iold,jold,1)-org(iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)-ansats(iold,jold,1)) - endif - endif - if (lock) then - start = org(i,j) - stopp = org(i,j) - return - endif - if (j >= 5) then - minmax = 4 - else - minmax = 4*j + 2 - endif - start = min(minmax,org(i,j)+(varmax-varupp(i,j))) - if (dubbel(i,j)) start = 2*(start/2) - stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) - return - end subroutine slug + jold,0)-ansats(iold,jold,1)) + endif + endif + if (lock) then + start = org(i,j) + stopp = org(i,j) + return + endif + if (j >= 5) then + minmax = 4 + else + minmax = 4*j + 2 + endif + start = min(minmax,org(i,j)+(varmax-varupp(i,j))) + if (dubbel(i,j)) start = 2*(start/2) + stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) + return + end subroutine slug diff --git a/src/appl/jjgen90/slug_I.f90 b/src/appl/jjgen90/slug_I.f90 index 7f5377bd7..a94306059 100644 --- a/src/appl/jjgen90/slug_I.f90 +++ b/src/appl/jjgen90/slug_I.f90 @@ -1,20 +1,20 @@ - MODULE slug_I + MODULE slug_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE slug (I, J, VARMAX, VARUPP, VARNED, ANSATS, ORG, LOCK, DUBBEL& - , LOW, START, STOPP) - integer, INTENT(IN) :: I - integer, INTENT(IN) :: J - integer, INTENT(IN) :: VARMAX - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - logical, INTENT(IN) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL - integer, DIMENSION(15,0:10), INTENT(IN) :: LOW - integer, INTENT(OUT) :: START - integer, INTENT(OUT) :: STOPP - END SUBROUTINE - END INTERFACE - END MODULE + , LOW, START, STOPP) + integer, INTENT(IN) :: I + integer, INTENT(IN) :: J + integer, INTENT(IN) :: VARMAX + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + logical, INTENT(IN) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL + integer, DIMENSION(15,0:10), INTENT(IN) :: LOW + integer, INTENT(OUT) :: START + integer, INTENT(OUT) :: STOPP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/sluggo.f90 b/src/appl/jjgen90/sluggo.f90 index 706581b00..f5b9a8875 100644 --- a/src/appl/jjgen90/sluggo.f90 +++ b/src/appl/jjgen90/sluggo.f90 @@ -1,63 +1,63 @@ - + ! last edited September 23, 1995 subroutine sluggo(i, j, varmax, varupp, varned, ansats, org, lock, low, & - start, stopp) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + start, stopp) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i - integer , intent(in) :: j - integer , intent(in) :: varmax - integer , intent(out) :: start - integer , intent(out) :: stopp - logical , intent(in) :: lock - integer , intent(inout) :: varupp(15,0:10) - integer , intent(inout) :: varned(15,0:10) - integer , intent(in) :: ansats(15,0:10,0:1) - integer , intent(in) :: org(15,0:10) - integer , intent(in) :: low(15,0:10) + integer , intent(in) :: i + integer , intent(in) :: j + integer , intent(in) :: varmax + integer , intent(out) :: start + integer , intent(out) :: stopp + logical , intent(in) :: lock + integer , intent(inout) :: varupp(15,0:10) + integer , intent(inout) :: varned(15,0:10) + integer , intent(in) :: ansats(15,0:10,0:1) + integer , intent(in) :: org(15,0:10) + integer , intent(in) :: low(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: minmax, iold, jold + integer :: minmax, iold, jold !----------------------------------------------- - if (i == 1) then - varupp(1,0) = 0 - varned(1,0) = 0 - else - if (j == 0) then - iold = i - 1 - jold = min(10,iold - 1) - else - iold = i - jold = j - 1 - endif - if (jold == 0) then + if (i == 1) then + varupp(1,0) = 0 + varned(1,0) = 0 + else + if (j == 0) then + iold = i - 1 + jold = min(10,iold - 1) + else + iold = i + jold = j - 1 + endif + if (jold == 0) then varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)-org(& - iold,jold)) + iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)) - else + jold,0)) + else varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)+ansats(& - iold,jold,1)-org(iold,jold)) + iold,jold,1)-org(iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)-ansats(iold,jold,1)) - endif - endif - if (lock) then - start = org(i,j) - stopp = org(i,j) - return - endif - if (j >= 5) then - minmax = 4 - else - minmax = 4*j + 2 - endif - start = min(minmax,org(i,j)+(varmax-varupp(i,j))) - stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) - return - end subroutine sluggo + jold,0)-ansats(iold,jold,1)) + endif + endif + if (lock) then + start = org(i,j) + stopp = org(i,j) + return + endif + if (j >= 5) then + minmax = 4 + else + minmax = 4*j + 2 + endif + start = min(minmax,org(i,j)+(varmax-varupp(i,j))) + stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) + return + end subroutine sluggo diff --git a/src/appl/jjgen90/sluggo_I.f90 b/src/appl/jjgen90/sluggo_I.f90 index 8b2e3bf62..a53add9f6 100644 --- a/src/appl/jjgen90/sluggo_I.f90 +++ b/src/appl/jjgen90/sluggo_I.f90 @@ -1,19 +1,19 @@ - MODULE sluggo_I + MODULE sluggo_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE sluggo (I, J, VARMAX, VARUPP, VARNED, ANSATS, ORG, LOCK, LOW& - , START, STOPP) - integer, INTENT(IN) :: I - integer, INTENT(IN) :: J - integer, INTENT(IN) :: VARMAX - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - logical, INTENT(IN) :: LOCK - integer, DIMENSION(15,0:10), INTENT(IN) :: LOW - integer, INTENT(OUT) :: START - integer, INTENT(OUT) :: STOPP - END SUBROUTINE - END INTERFACE - END MODULE + , START, STOPP) + integer, INTENT(IN) :: I + integer, INTENT(IN) :: J + integer, INTENT(IN) :: VARMAX + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + logical, INTENT(IN) :: LOCK + integer, DIMENSION(15,0:10), INTENT(IN) :: LOW + integer, INTENT(OUT) :: START + integer, INTENT(OUT) :: STOPP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/jjgen90/test.f90 b/src/appl/jjgen90/test.f90 index c855ae30f..7b436bc0d 100644 --- a/src/appl/jjgen90/test.f90 +++ b/src/appl/jjgen90/test.f90 @@ -1,47 +1,47 @@ ! last edited October 31, 1996 - subroutine test(p1, p2, pop1, pop2, nmax) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine test(p1, p2, pop1, pop2, nmax) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: nmax - logical , intent(out) :: p1 - logical , intent(out) :: p2 - integer , intent(in) :: pop1(15,0:10,0:1) - integer , intent(in) :: pop2(15,0:10,0:1) + integer , intent(in) :: nmax + logical , intent(out) :: p1 + logical , intent(out) :: p2 + integer , intent(in) :: pop1(15,0:10,0:1) + integer , intent(in) :: pop2(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: n, l, k + integer :: n, l, k !----------------------------------------------- - - p1 = .TRUE. - p2 = .TRUE. - do n = 1, nmax - do l = 0, min(10,n - 1) - if (pop1(n,l,1) + pop1(n,l,0) < pop2(n,l,1) + pop2(n,l,0)) then - p1 = .FALSE. - return + + p1 = .TRUE. + p2 = .TRUE. + do n = 1, nmax + do l = 0, min(10,n - 1) + if (pop1(n,l,1) + pop1(n,l,0) < pop2(n,l,1) + pop2(n,l,0)) then + p1 = .FALSE. + return else if (pop1(n,l,1) + pop1(n,l,0) > pop2(n,l,1) + pop2(n,l,0)) & - then - p2 = .FALSE. - return - else if (pop1(n,l,1) < pop2(n,l,1)) then - p1 = .FALSE. - return - else if (pop1(n,l,1) > pop2(n,l,1)) then - p2 = .FALSE. - return - else if (pop1(n,l,0) < pop2(n,l,0)) then - p1 = .FALSE. - return - else if (pop1(n,l,0) > pop2(n,l,0)) then - p2 = .FALSE. - return - endif - end do - end do - return - end subroutine test + then + p2 = .FALSE. + return + else if (pop1(n,l,1) < pop2(n,l,1)) then + p1 = .FALSE. + return + else if (pop1(n,l,1) > pop2(n,l,1)) then + p2 = .FALSE. + return + else if (pop1(n,l,0) < pop2(n,l,0)) then + p1 = .FALSE. + return + else if (pop1(n,l,0) > pop2(n,l,0)) then + p2 = .FALSE. + return + endif + end do + end do + return + end subroutine test diff --git a/src/appl/jjgen90/test_I.f90 b/src/appl/jjgen90/test_I.f90 index 282a83ee6..cfaa308d8 100644 --- a/src/appl/jjgen90/test_I.f90 +++ b/src/appl/jjgen90/test_I.f90 @@ -1,12 +1,12 @@ - MODULE test_I + MODULE test_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE test (P1, P2, POP1, POP2, NMAX) - logical, INTENT(OUT) :: P1 - logical, INTENT(OUT) :: P2 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP2 - integer, INTENT(IN) :: NMAX - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE test (P1, P2, POP1, POP2, NMAX) + logical, INTENT(OUT) :: P1 + logical, INTENT(OUT) :: P2 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP2 + integer, INTENT(IN) :: NMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/Makefile b/src/appl/rangular90/Makefile index 17d96d5ad..a60695b7c 100644 --- a/src/appl/rangular90/Makefile +++ b/src/appl/rangular90/Makefile @@ -11,7 +11,7 @@ MODLRANG90 = ${SRCLIBDIR}/librang90 MODLMCP90 = ${SRCLIBDIR}/libmcp90 GRASPLIBS = -l9290 -lrang90 -l9290 -lmcp90 -lmod -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} # Define data types @@ -39,4 +39,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rangular90/allocCheck.f90 b/src/appl/rangular90/allocCheck.f90 index ae7b66a0d..f3f6a3999 100644 --- a/src/appl/rangular90/allocCheck.f90 +++ b/src/appl/rangular90/allocCheck.f90 @@ -4,11 +4,11 @@ SUBROUTINE allocCheck(n, IREZ) ! * ! Written by G. Gaigalas Last revision: 27 October 2017 * ! * -! * +! * !*********************************************************************** ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE memory_man diff --git a/src/appl/rangular90/allocCheck_I.f90 b/src/appl/rangular90/allocCheck_I.f90 index 063882dff..90f856d93 100644 --- a/src/appl/rangular90/allocCheck_I.f90 +++ b/src/appl/rangular90/allocCheck_I.f90 @@ -1,8 +1,8 @@ - MODULE allocCheck_I + MODULE allocCheck_I INTERFACE SUBROUTINE allocCheck(n, IREZ) INTEGER, INTENT(IN) :: n INTEGER, INTENT(OUT) :: IREZ - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/cons_C.f90 b/src/appl/rangular90/cons_C.f90 old mode 100755 new mode 100644 index 61c5cf20f..e07235e38 --- a/src/appl/rangular90/cons_C.f90 +++ b/src/appl/rangular90/cons_C.f90 @@ -1,12 +1,12 @@ ! !*********************************************************************** ! * - MODULE cons_C + MODULE cons_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE) :: ZERO = 0.0D00, & HALF = 0.5D00, & @@ -19,4 +19,4 @@ MODULE cons_C TEN =10.0D00, & ELEVEN=11.0D00, & EPS = 1.0D-08 - END MODULE cons_C + END MODULE cons_C diff --git a/src/appl/rangular90/fndbeg.f90 b/src/appl/rangular90/fndbeg.f90 index 06327eef1..f39aa7e76 100644 --- a/src/appl/rangular90/fndbeg.f90 +++ b/src/appl/rangular90/fndbeg.f90 @@ -1,12 +1,12 @@ !*********************************************************************** ! * - SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) + SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- @@ -18,17 +18,17 @@ SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: JASTRT - INTEGER, INTENT(INOUT) :: JBSTRT - INTEGER, INTENT(INOUT) :: INDEX - INTEGER, INTENT(OUT) :: LLISTT + INTEGER, INTENT(INOUT) :: JASTRT + INTEGER, INTENT(INOUT) :: JBSTRT + INTEGER, INTENT(INOUT) :: INDEX + INTEGER, INTENT(OUT) :: LLISTT INTEGER, DIMENSION(:), pointer :: LLISTV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IOS, ICREAD, IRREAD, INDX, NREC, I, LABEL - REAL(DOUBLE) :: COEFF - CHARACTER :: SRTLAB*8, MCPLAB*3 + INTEGER :: K, IOS, ICREAD, IRREAD, INDX, NREC, I, LABEL + REAL(DOUBLE) :: COEFF + CHARACTER :: SRTLAB*8, MCPLAB*3 !----------------------------------------------- ! ! Begin by examining file 30; this is the last to be updated by @@ -36,91 +36,91 @@ SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) ! ! Read and check the character part of the file header ! - REWIND (30) - READ (30) MCPLAB, SRTLAB - IF (SRTLAB == ' SORTED') THEN - JASTRT = NCF + 1 - JBSTRT = NCF + 1 - LLISTT = 0 - LLISTV(:KMAX) = 0 - GO TO 8 - ENDIF + REWIND (30) + READ (30) MCPLAB, SRTLAB + IF (SRTLAB == ' SORTED') THEN + JASTRT = NCF + 1 + JBSTRT = NCF + 1 + LLISTT = 0 + LLISTV(:KMAX) = 0 + GO TO 8 + ENDIF ! - READ (30) - READ (30) + READ (30) + READ (30) ! ! Read as many records as possible ! - 2 CONTINUE - READ (30, IOSTAT=IOS) ICREAD, IRREAD, INDX + 2 CONTINUE + READ (30, IOSTAT=IOS) ICREAD, IRREAD, INDX ! - IF (IOS == 0) THEN + IF (IOS == 0) THEN ! ! No errors or end-of-file; keep reading ! - JASTRT = ICREAD - JBSTRT = IRREAD - INDEX = INDX - GO TO 2 + JASTRT = ICREAD + JBSTRT = IRREAD + INDEX = INDX + GO TO 2 ! - ELSE + ELSE ! - IF (JASTRT==NCF .AND. JBSTRT==NCF) THEN + IF (JASTRT==NCF .AND. JBSTRT==NCF) THEN ! ! All coefficients have been generated; sorting may still ! be necessary; force this option ! - JASTRT = NCF + 1 - JBSTRT = NCF + 1 + JASTRT = NCF + 1 + JBSTRT = NCF + 1 ! - ELSE + ELSE ! ! Some coefficients remain to be generated; reposition all files ! for augmentation of lists by SUBROUTINE MCP; update JBSTRT and, ! if appropriate, JASTRT ! - DO K = 31, 32 + KMAX - REWIND (K) - NREC = 3 - DO I = 1, NREC - READ (K) - END DO - 4 CONTINUE - READ (K, IOSTAT=IOS) INDX, LABEL, COEFF - IF (IOS==0 .AND. INDX<=INDEX) THEN - NREC = NREC + 1 - GO TO 4 - ELSE - REWIND (K) - DO I = 1, NREC - READ (K) - END DO - IF (K > 31) THEN - LLISTV(K-32) = NREC - 3 - ELSE - LLISTT = NREC - 3 - ENDIF - ENDIF - END DO + DO K = 31, 32 + KMAX + REWIND (K) + NREC = 3 + DO I = 1, NREC + READ (K) + END DO + 4 CONTINUE + READ (K, IOSTAT=IOS) INDX, LABEL, COEFF + IF (IOS==0 .AND. INDX<=INDEX) THEN + NREC = NREC + 1 + GO TO 4 + ELSE + REWIND (K) + DO I = 1, NREC + READ (K) + END DO + IF (K > 31) THEN + LLISTV(K-32) = NREC - 3 + ELSE + LLISTT = NREC - 3 + ENDIF + ENDIF + END DO ! ! Now, reposition the sms file. This file should contain the ! same number of data records as file 33. - - REWIND (20) - DO I = 1, LLISTV(1) - READ (20) - END DO - - JBSTRT = JBSTRT + 1 - IF (JBSTRT > NCF) THEN - JASTRT = JASTRT + 1 - JBSTRT = JASTRT - ENDIF -! - ENDIF -! - ENDIF -! - 8 CONTINUE - RETURN - END SUBROUTINE FNDBEG + + REWIND (20) + DO I = 1, LLISTV(1) + READ (20) + END DO + + JBSTRT = JBSTRT + 1 + IF (JBSTRT > NCF) THEN + JASTRT = JASTRT + 1 + JBSTRT = JASTRT + ENDIF +! + ENDIF +! + ENDIF +! + 8 CONTINUE + RETURN + END SUBROUTINE FNDBEG diff --git a/src/appl/rangular90/fndbeg_I.f90 b/src/appl/rangular90/fndbeg_I.f90 index da07212ac..2f5c842ac 100644 --- a/src/appl/rangular90/fndbeg_I.f90 +++ b/src/appl/rangular90/fndbeg_I.f90 @@ -1,14 +1,14 @@ - MODULE fndbeg_I + MODULE fndbeg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fndbeg (JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) - INTEGER, INTENT(INOUT) :: JASTRT - INTEGER, INTENT(INOUT) :: JBSTRT - INTEGER, INTENT(INOUT) :: INDEX - INTEGER, INTENT(OUT) :: LLISTT + SUBROUTINE fndbeg (JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) + INTEGER, INTENT(INOUT) :: JASTRT + INTEGER, INTENT(INOUT) :: JBSTRT + INTEGER, INTENT(INOUT) :: INDEX + INTEGER, INTENT(OUT) :: LLISTT INTEGER, DIMENSION(:), pointer :: LLISTV - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/genmcp.f90 b/src/appl/rangular90/genmcp.f90 index 6ee26cbe3..eba4e339f 100644 --- a/src/appl/rangular90/genmcp.f90 +++ b/src/appl/rangular90/genmcp.f90 @@ -1,4 +1,4 @@ - + !*********************************************************************** !*********************************************************************** !*********************************************************************** @@ -22,7 +22,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM GENMCP + PROGRAM GENMCP ! * ! Written by Farid A. Parpia Last revision: 11 Dec 1992 * ! MPI version by Xinghong He Last revision: 29 Jun 1998 * @@ -33,11 +33,11 @@ PROGRAM GENMCP ! 2) for sorting in the memory. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE memory_man @@ -53,24 +53,24 @@ PROGRAM GENMCP !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE starttime_I - USE setdbg_I - USE setmc_I - USE setsum_I - USE cslh_I - USE setmcp2_I - USE strsum_I - USE factt_I -! USE settmp_I + USE getyn_I + USE starttime_I + USE setdbg_I + USE setmc_I + USE setsum_I + USE cslh_I + USE setmcp2_I + USE strsum_I + USE factt_I +! USE settmp_I USE settmpgg_I - USE stoptime_I + USE stoptime_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER NBLK0, NCOUNT1, NCORE, NB - PARAMETER (NBLK0 = 50) + PARAMETER (NBLK0 = 50) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -88,24 +88,24 @@ PROGRAM GENMCP write(*,*) 'rangular.log ' write(*,*) OPEN(UNIT=739,FILE='rangular.log',STATUS='UNKNOWN') - MYID = 0 - NPROCS = 1 - CALL STARTTIME (NCOUNT1, 'RANGULAR') + MYID = 0 + NPROCS = 1 + CALL STARTTIME (NCOUNT1, 'RANGULAR') !======================================================================= ! Get NDEF !======================================================================= - IF (MYID == 0) THEN -! WRITE (ISTDE, '(A)', ADVANCE='NO') 'Default settings? (y/n) ' + IF (MYID == 0) THEN +! WRITE (ISTDE, '(A)', ADVANCE='NO') 'Default settings? (y/n) ' WRITE (istde,'(A)') ' Full interaction? (y/n) ' - YES = GETYN() - IF (YES) THEN - NDEF = 0 + YES = GETYN() + IF (YES) THEN + NDEF = 0 write(739,'(A)') 'y ! Full interaction' - ELSE - NDEF = 1 + ELSE + NDEF = 1 write(739,'(A)') 'n ! Full interaction' - ENDIF - ENDIF + ENDIF + ENDIF !======================================================================= ! ! Checks and settings... Mostly done in backyard. @@ -120,42 +120,42 @@ PROGRAM GENMCP ! factt - table of logarithms of factorials setup !======================================================================= !CFF delete chkplt -! CALL CHKPLT ('GENMCP') - CALL SETDBG (DEBUG, 'genmcp.dbg') - CALL SETMC -! IF (NDEF/=0 .AND. MYID==0) CALL SETSUM ('genmcp.sum') - CALL CSLH ('rcsf.inp', NCORE, NBLK0, IDBLK) - RESTRT = .FALSE. - CALL SETMCP2 (MYID, NPROCS, NCORE, IDBLK, 'mcp') - IF (NDEF/=0 .AND. MYID==0) CALL STRSUM - CALL FACTT +! CALL CHKPLT ('GENMCP') + CALL SETDBG (DEBUG, 'genmcp.dbg') + CALL SETMC +! IF (NDEF/=0 .AND. MYID==0) CALL SETSUM ('genmcp.sum') + CALL CSLH ('rcsf.inp', NCORE, NBLK0, IDBLK) + RESTRT = .FALSE. + CALL SETMCP2 (MYID, NPROCS, NCORE, IDBLK, 'mcp') + IF (NDEF/=0 .AND. MYID==0) CALL STRSUM + CALL FACTT !======================================================================= ! For each block, generate and sort the data !======================================================================= - DO NB = 1, NBLOCK - NCF = NCFBLK(NB) ! This ncf goes to common - IF (MYID == 0) THEN - WRITE (6, *) - WRITE (6, *) 'Block ', NB, ', ncf = ', NCF - ENDIF + DO NB = 1, NBLOCK + NCF = NCFBLK(NB) ! This ncf goes to common + IF (MYID == 0) THEN + WRITE (6, *) + WRITE (6, *) 'Block ', NB, ', ncf = ', NCF + ENDIF !*** Load current CSL block. Memories de-allocated in mcp *** CALL ALLOC (iqa, NNNW, NCF, 'IQA', 'GENMCP') CALL ALLOC (jqsa, NNNW,3,NCF, 'JQSA', 'GENMCP') CALL ALLOC (jcupa, NNNW, NCF, 'JCUPA', 'GENMCP') ! - CALL LODCSH2 (21, NCORE, NB) + CALL LODCSH2 (21, NCORE, NB) !*** Open tmp.xx files for block nb *** -!GG CALL SETTMP (NB, KMAX, 'tmp') +!GG CALL SETTMP (NB, KMAX, 'tmp') CALL SETTMPGG (nb, 30, 'tmp') !*** Generation of MCP coefficients *** - CALL MCP (NB, RESTRT, MYID, NPROCS, 'mcp') - END DO - CLOSE(24) ! Summary file + CALL MCP (NB, RESTRT, MYID, NPROCS, 'mcp') + END DO + CLOSE(24) ! Summary file CLOSE(739) ! rangular.log - IF (DEBUG) CLOSE(99) ! Debug file + IF (DEBUG) CLOSE(99) ! Debug file !======================================================================= ! Execution finished; Statistics output !======================================================================= - CALL STOPTIME (NCOUNT1, 'RANGULAR') - STOP + CALL STOPTIME (NCOUNT1, 'RANGULAR') + STOP END PROGRAM GENMCP diff --git a/src/appl/rangular90/getinf.f90 b/src/appl/rangular90/getinf.f90 index f58350347..5da186a6f 100644 --- a/src/appl/rangular90/getinf.f90 +++ b/src/appl/rangular90/getinf.f90 @@ -15,8 +15,8 @@ SUBROUTINE GETINF ! Updated to treat ICCUT for block ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -51,7 +51,7 @@ SUBROUTINE GETINF ! DIAG = GETYN () ! ELSE ! DIAG = .FALSE. -! ENDIF +! ENDIF DIAG = .FALSE. IF (DIAG) THEN LFORDR = .FALSE. diff --git a/src/appl/rangular90/getinf_I.f90 b/src/appl/rangular90/getinf_I.f90 index 78b2f8424..bf4b087ec 100644 --- a/src/appl/rangular90/getinf_I.f90 +++ b/src/appl/rangular90/getinf_I.f90 @@ -1,9 +1,9 @@ - MODULE getinf_I + MODULE getinf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getinf - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getinf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/mcp_gg.f90 b/src/appl/rangular90/mcp_gg.f90 index c4ee9a4c3..4383b55ff 100644 --- a/src/appl/rangular90/mcp_gg.f90 +++ b/src/appl/rangular90/mcp_gg.f90 @@ -24,8 +24,8 @@ SUBROUTINE mcp (nb, RESTRT, myid, nprocs, fhead) ! 2) for sorting in the memory. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -47,7 +47,7 @@ SUBROUTINE mcp (nb, RESTRT, myid, nprocs, fhead) !----------------------------------------------- ! C O M M O N B L O C K S !----------------------------------------------- - USE BUFFER_C, ONLY: NVCOEF, LABEL, COEFF + USE BUFFER_C, ONLY: NVCOEF, LABEL, COEFF USE DEBUG_C, ONLY: LDBPA USE DEFAULT_C, ONLY: NDEF USE iccu_C, ONLY: ICCUT @@ -187,7 +187,7 @@ SUBROUTINE mcp (nb, RESTRT, myid, nprocs, fhead) TCOEFF(LLISTT,1) = TSHELL(1) ELSE !GG print*,"LLISTT =",LLISTT -!GG print*, +!GG print*, !GG : "The program switches to the disk version of !sorting" CALL SETTMPGG (nb, 31, 'tmp') @@ -279,7 +279,7 @@ SUBROUTINE mcp (nb, RESTRT, myid, nprocs, fhead) TCOEFF(LLISTV(K),K+2) = VCOEFF ELSE !GG print*,"K=",K," LLISTV =",LLISTV(K) -!GG print*, +!GG print*, !GG : "The program switches to the disk version of !sorting" CALL SETTMPGG (nb, 32+K, 'tmp') diff --git a/src/appl/rangular90/mcp_gg_I.f90 b/src/appl/rangular90/mcp_gg_I.f90 index b1b8b55a9..2c578f56c 100644 --- a/src/appl/rangular90/mcp_gg_I.f90 +++ b/src/appl/rangular90/mcp_gg_I.f90 @@ -1,7 +1,7 @@ MODULE mcp_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE mcp (nb, RESTRT, myid, nprocs, fhead) INTEGER :: NB diff --git a/src/appl/rangular90/outsda.f90 b/src/appl/rangular90/outsda.f90 index 938b0009d..2a6db2cb8 100644 --- a/src/appl/rangular90/outsda.f90 +++ b/src/appl/rangular90/outsda.f90 @@ -1,17 +1,17 @@ -!*********************************************************************** - SUBROUTINE OUTSDA(LPRINT,NNONZ, NCF) -!*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!*********************************************************************** + SUBROUTINE OUTSDA(LPRINT,NNONZ, NCF) +!*********************************************************************** +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- - IMPLICIT NONE + IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NNONZ - INTEGER, INTENT(IN) :: NCF - LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NNONZ + INTEGER, INTENT(IN) :: NCF + LOGICAL, INTENT(IN) :: LPRINT !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- @@ -19,26 +19,26 @@ SUBROUTINE OUTSDA(LPRINT,NNONZ, NCF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NNONZ_A + INTEGER :: NNONZ_A !----------------------------------------------- - NNONZ_A = NNONZ - + NNONZ_A = NNONZ + WRITE(6, *)' ... complete; density of non-zero elements of H(DC):', & - NNONZ_A, '/', (NCF*(NCF + 1))/2 + NNONZ_A, '/', (NCF*(NCF + 1))/2 ! ! Debug printout ! - IF (LPRINT) THEN - WRITE (99, *) - WRITE (99, *) 'From ', MYNAME, ' :' - WRITE (99, 301) NNONZ_A - - WRITE (6, *) 'This part not finished. See ', MYNAME - WRITE (99, *) 'This part not finished. See ', MYNAME - ENDIF - - 301 FORMAT(' Number of nonzero elements in H(DC): ',1I4) - 302 FORMAT(' Column ',1I2,', row ',1I2,', sparse matrix index ',1I4) - - RETURN - END SUBROUTINE OUTSDA + IF (LPRINT) THEN + WRITE (99, *) + WRITE (99, *) 'From ', MYNAME, ' :' + WRITE (99, 301) NNONZ_A + + WRITE (6, *) 'This part not finished. See ', MYNAME + WRITE (99, *) 'This part not finished. See ', MYNAME + ENDIF + + 301 FORMAT(' Number of nonzero elements in H(DC): ',1I4) + 302 FORMAT(' Column ',1I2,', row ',1I2,', sparse matrix index ',1I4) + + RETURN + END SUBROUTINE OUTSDA diff --git a/src/appl/rangular90/outsda_I.f90 b/src/appl/rangular90/outsda_I.f90 index 5f2bca6ac..93e833fe7 100644 --- a/src/appl/rangular90/outsda_I.f90 +++ b/src/appl/rangular90/outsda_I.f90 @@ -1,12 +1,12 @@ - MODULE outsda_I + MODULE outsda_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE outsda (LPRINT, NNONZ, NCF) - LOGICAL, INTENT(IN) :: LPRINT - INTEGER, INTENT(IN) :: NNONZ - INTEGER, INTENT(IN) :: NCF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE outsda (LPRINT, NNONZ, NCF) + LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NNONZ + INTEGER, INTENT(IN) :: NCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/setdbg.f90 b/src/appl/rangular90/setdbg.f90 index 118f2af9a..2c05a197b 100644 --- a/src/appl/rangular90/setdbg.f90 +++ b/src/appl/rangular90/setdbg.f90 @@ -14,7 +14,7 @@ SUBROUTINE SETDBG (DEBUG, fullname) ! * !*********************************************************************** !...Translated by Pacific-Sierra Research 77to90 4.3E 11:11:16 12/23/06 -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -55,7 +55,7 @@ SUBROUTINE SETDBG (DEBUG, fullname) IF (NDEF .EQ. 0) THEN RETURN ENDIF - + WRITE (istde,*) 'Generate debug printout?' DEBUG = GETYN () IF (DEBUG) THEN @@ -97,7 +97,7 @@ SUBROUTINE SETDBG (DEBUG, fullname) LDBPA(3) = GETYN () WRITE (istde,*) ' Print out sparse matrix definition arrays?' LDBPA(4) = GETYN () - + ENDIF ! RETURN diff --git a/src/appl/rangular90/setdbg_I.f90 b/src/appl/rangular90/setdbg_I.f90 index 6575c6e57..8cce54973 100644 --- a/src/appl/rangular90/setdbg_I.f90 +++ b/src/appl/rangular90/setdbg_I.f90 @@ -1,7 +1,7 @@ MODULE SETDBG_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETDBG (DEBUG, fullname) LOGICAL :: DEBUG diff --git a/src/appl/rangular90/setmcp.f90 b/src/appl/rangular90/setmcp.f90 index a7cdb2515..7f18b887f 100644 --- a/src/appl/rangular90/setmcp.f90 +++ b/src/appl/rangular90/setmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETMCP(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) + SUBROUTINE SETMCP(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) ! * ! Open and check the .mcp files. File 30 stores the structure of * ! H(DC) ; file 31 stores the T coefficients; files 32, 33, ..., * @@ -15,11 +15,11 @@ SUBROUTINE SETMCP(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) ! Used by mcpvu, mcpmpivu ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- @@ -33,57 +33,57 @@ SUBROUTINE SETMCP(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - INTEGER, INTENT(IN) :: NCORE - CHARACTER, INTENT(IN) :: FILEHEAD*(*) - CHARACTER, INTENT(IN) :: IDBLK(*)*8 + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + INTEGER, INTENT(IN) :: NCORE + CHARACTER, INTENT(IN) :: FILEHEAD*(*) + CHARACTER, INTENT(IN) :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, LNG, LCK, IERR, I - LOGICAL :: FOUND, FOUND1, GETYN, YES - CHARACTER :: CK*2 + INTEGER :: K, LNG, LCK, IERR, I + LOGICAL :: FOUND, FOUND1, GETYN, YES + CHARACTER :: CK*2 !----------------------------------------------- ! Determine KMAX; this is the number of .mcp files for the ! two-electron integrals - - KMAX = 0 - DO K = 1, NW - KMAX = MAX(KMAX,NKJ(K)) - END DO - + + KMAX = 0 + DO K = 1, NW + KMAX = MAX(KMAX,NKJ(K)) + END DO + ! All files mcp.xx are UNFORMATTED; - - LNG = LEN_TRIM(FILEHEAD) - DO K = 30, 32 + KMAX - CALL CONVRT (K, CK, LCK) + + LNG = LEN_TRIM(FILEHEAD) + DO K = 30, 32 + KMAX + CALL CONVRT (K, CK, LCK) CALL OPENFL (K, FILEHEAD(1:LNG)//'.'//CK(1:2), 'UNFORMATTED', & - 'UNKNOWN', IERR) - IF (IERR == 0) CYCLE - DO I = 30, K - CLOSE(I) - END DO - WRITE (ISTDE, *) 'Error when opening the mcp files' - STOP - END DO + 'UNKNOWN', IERR) + IF (IERR == 0) CYCLE + DO I = 30, K + CLOSE(I) + END DO + WRITE (ISTDE, *) 'Error when opening the mcp files' + STOP + END DO ! ! We want to know kmax before openning other mcp files (not mcp.30) ! in rscf ! - WRITE (30) NCORE, NBLOCK, KMAX - WRITE (30) (NCFBLK(I),I=1,NBLOCK) - WRITE (30) (IDBLK(I),I=1,NBLOCK) - - DO K = 30, 32 + KMAX - WRITE (K) 'MCP', NBLOCK, MYID, NPROCS - END DO - - RETURN - END SUBROUTINE SETMCP + WRITE (30) NCORE, NBLOCK, KMAX + WRITE (30) (NCFBLK(I),I=1,NBLOCK) + WRITE (30) (IDBLK(I),I=1,NBLOCK) + + DO K = 30, 32 + KMAX + WRITE (K) 'MCP', NBLOCK, MYID, NPROCS + END DO + + RETURN + END SUBROUTINE SETMCP diff --git a/src/appl/rangular90/setmcp2.f90 b/src/appl/rangular90/setmcp2.f90 index d2621b1ee..962bad6de 100644 --- a/src/appl/rangular90/setmcp2.f90 +++ b/src/appl/rangular90/setmcp2.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE SETMCP2(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) + SUBROUTINE SETMCP2(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) ! ! A wrapper for setmcp/getinf. setmcp/getinf are then shared by serial ! and MPI programs. @@ -7,11 +7,11 @@ SUBROUTINE SETMCP2(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) ! Written by Xinghong He Last revision: 30 Jun 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- @@ -24,35 +24,35 @@ SUBROUTINE SETMCP2(MYID, NPROCS, NCORE, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setmcp_I - USE getinf_I + USE setmcp_I + USE getinf_I !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: MYID - INTEGER :: NPROCS - INTEGER :: NCORE - CHARACTER :: FILEHEAD*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: MYID + INTEGER :: NPROCS + INTEGER :: NCORE + CHARACTER :: FILEHEAD*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K - - CALL SETMCP (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) - + INTEGER :: K + + CALL SETMCP (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) + ! DIAG, ICCUTblk, LFORDR are set in GETINF - - IF (MYID == 0) CALL GETINF - - DO K = 30, 32 + KMAX - WRITE (K) NELEC, NCF, NW - WRITE (K) DIAG, ICCUT(1), LFORDR - END DO - - DO K = 30, 32 + KMAX - CLOSE(K) - END DO - - RETURN - END SUBROUTINE SETMCP2 + + IF (MYID == 0) CALL GETINF + + DO K = 30, 32 + KMAX + WRITE (K) NELEC, NCF, NW + WRITE (K) DIAG, ICCUT(1), LFORDR + END DO + + DO K = 30, 32 + KMAX + CLOSE(K) + END DO + + RETURN + END SUBROUTINE SETMCP2 diff --git a/src/appl/rangular90/setmcp2_I.f90 b/src/appl/rangular90/setmcp2_I.f90 index 919ae5a56..7f58102eb 100644 --- a/src/appl/rangular90/setmcp2_I.f90 +++ b/src/appl/rangular90/setmcp2_I.f90 @@ -1,14 +1,14 @@ - MODULE setmcp2_I + MODULE setmcp2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmcp2 (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) - INTEGER, INTENT(IN) :: MYID - INTEGER :: NPROCS - INTEGER :: NCORE - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - CHARACTER (LEN = *) :: FILEHEAD - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmcp2 (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) + INTEGER, INTENT(IN) :: MYID + INTEGER :: NPROCS + INTEGER :: NCORE + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + CHARACTER (LEN = *) :: FILEHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/setmcp_I.f90 b/src/appl/rangular90/setmcp_I.f90 index e6015e8a1..7fb4f1de8 100644 --- a/src/appl/rangular90/setmcp_I.f90 +++ b/src/appl/rangular90/setmcp_I.f90 @@ -1,15 +1,15 @@ - MODULE setmcp_I + MODULE setmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmcp (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - INTEGER, INTENT(IN) :: NCORE - CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + SUBROUTINE setmcp (MYID, NPROCS, NCORE, IDBLK, FILEHEAD) + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + INTEGER, INTENT(IN) :: NCORE + CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/setsda.f90 b/src/appl/rangular90/setsda.f90 index 5061614b6..024f7b781 100644 --- a/src/appl/rangular90/setsda.f90 +++ b/src/appl/rangular90/setsda.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) + SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) ! * ! This routine examines lists * ! (IC,IR,npos) * @@ -16,8 +16,8 @@ SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) ! Currently shared by mcpblk, mcpmpi ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -31,80 +31,80 @@ SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE outsda_I + USE outsda_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- EXTERNAL OUTSDAdummy INTEGER, INTENT(IN) :: NNONZ - INTEGER, INTENT(IN) :: NB - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - LOGICAL :: LPRINT - CHARACTER, INTENT(IN) :: FHEAD*(*) + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + LOGICAL :: LPRINT + CHARACTER, INTENT(IN) :: FHEAD*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MB, IEND, ICLAST, I, IC, NPOS, IERR + INTEGER :: MB, IEND, ICLAST, I, IC, NPOS, IERR INTEGER, DIMENSION(:), pointer :: IENDC - INTEGER, DIMENSION(:), pointer :: IROW - CHARACTER :: MCPLAB*3 + INTEGER, DIMENSION(:), pointer :: IROW + CHARACTER :: MCPLAB*3 !----------------------------------------------- - + IF (MYID == 0) WRITE (6, *) & - 'Analysing sparse matrix array definition file ...', 30 - - READ (30) MCPLAB, MB - IF (NB /= MB) THEN - WRITE (ISTDE, *) 'setsda: nb = ', NB, '.NE. mb (=', MB, ')' - STOP - ENDIF + 'Analysing sparse matrix array definition file ...', 30 + + READ (30) MCPLAB, MB + IF (NB /= MB) THEN + WRITE (ISTDE, *) 'setsda: nb = ', NB, '.NE. mb (=', MB, ')' + STOP + ENDIF ! ! Allocate storage for IENDC(0:NCF) ! - CALL ALLOC (IENDC, 0, NCF,'IENDC','SETSDA' ) - CALL ALLOC (IROW, NNONZ, 'IROW', 'SETSDA' ) + CALL ALLOC (IENDC, 0, NCF,'IENDC','SETSDA' ) + CALL ALLOC (IROW, NNONZ, 'IROW', 'SETSDA' ) ! ! Analyse data on file 30; set up IENDC and IROW ! In multiprocessor environment, iendc of each node will have the ! same length (ncf+1); but will have its own part filled. irow is ! local, and its length is determined by the local parameter nnonz. - - IEND = 0 - ICLAST = 0 - DO I = 1, NNONZ - READ (30) IC, IROW(I), NPOS - IF (IC /= ICLAST) THEN - IENDC(ICLAST) = IEND - ICLAST = IC - ENDIF - IEND = NPOS - END DO + + IEND = 0 + ICLAST = 0 + DO I = 1, NNONZ + READ (30) IC, IROW(I), NPOS + IF (IC /= ICLAST) THEN + IENDC(ICLAST) = IEND + ICLAST = IC + ENDIF + IEND = NPOS + END DO !xhh - changed to suits MPI environment as well ! IENDC(NCF) = IEND - IENDC(IC) = IEND + IENDC(IC) = IEND ! ! Sorting complete; rewrite to mcpXXX.30 file ! OPEN(29, FILE=FHEAD//'.30', STATUS='OLD', FORM='UNFORMATTED', IOSTAT=IERR& - , POSITION='APPEND') - IF (IERR /= 0) THEN - WRITE (ISTDE, *) ' Error when opening the file mcp.30' - STOP - ENDIF - - WRITE (29) 'MCP', NB, NCF - WRITE (29) NNONZ - WRITE (29) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NNONZ) - CLOSE(29) + , POSITION='APPEND') + IF (IERR /= 0) THEN + WRITE (ISTDE, *) ' Error when opening the file mcp.30' + STOP + ENDIF + + WRITE (29) 'MCP', NB, NCF + WRITE (29) NNONZ + WRITE (29) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NNONZ) + CLOSE(29) !cjb ! ! Deallocate storage ! - CALL DALLOC (IENDC, 'IENDC', 'SETSDA') - CALL DALLOC (IROW, 'IROW', 'SETSDA') + CALL DALLOC (IENDC, 'IENDC', 'SETSDA') + CALL DALLOC (IROW, 'IROW', 'SETSDA') ! CALL OUTSDAdummy (LPRINT, NNONZ, NCF) - RETURN - END SUBROUTINE SETSDA + RETURN + END SUBROUTINE SETSDA diff --git a/src/appl/rangular90/setsda_I.f90 b/src/appl/rangular90/setsda_I.f90 index e1a5ad379..59822438b 100644 --- a/src/appl/rangular90/setsda_I.f90 +++ b/src/appl/rangular90/setsda_I.f90 @@ -1,16 +1,16 @@ - MODULE setsda_I + MODULE setsda_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE setsda (OUTSDA, NNONZ, LPRINT, NB, MYID, NPROCS, FHEAD) - EXTERNAL OUTSDA - INTEGER, INTENT(IN) :: NNONZ - LOGICAL :: LPRINT - INTEGER, INTENT(IN) :: NB - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - CHARACTER (LEN = *), INTENT(IN) :: FHEAD - END SUBROUTINE - END INTERFACE - END MODULE + EXTERNAL OUTSDA + INTEGER, INTENT(IN) :: NNONZ + LOGICAL :: LPRINT + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + CHARACTER (LEN = *), INTENT(IN) :: FHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/setsum.f90 b/src/appl/rangular90/setsum.f90 index 6d68ec2d4..f0b6d02e6 100644 --- a/src/appl/rangular90/setsum.f90 +++ b/src/appl/rangular90/setsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSUM(FULLNAME) + SUBROUTINE SETSUM(FULLNAME) ! * ! Open the .sum file on stream 24. * ! * @@ -12,18 +12,18 @@ SUBROUTINE SETSUM(FULLNAME) ! File shared by mcpblk, mcpmpi ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE IOUNIT_C + USE vast_kind_param, ONLY: DOUBLE + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -32,33 +32,33 @@ SUBROUTINE SETSUM(FULLNAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR + INTEGER :: IERR CHARACTER(LEN=120) :: FILNAM ! The original did not compile CHARACTER(LEN=11) :: FORM CHARACTER(LEN=3) :: STATUS !----------------------------------------------- - FORM = 'FORMATTED' - STATUS = 'NEW' + FORM = 'FORMATTED' + STATUS = 'NEW' ! WRITE (ISTDE, *) 'File ', FULLNAME, ' will be created as the', & - ' GENMCP SUMmary File;' + ' GENMCP SUMmary File;' WRITE (ISTDE, *) 'enter another file name if this is not ', & - 'acceptable; null otherwise:' - READ (*, '(A)') FILNAM + 'acceptable; null otherwise:' + READ (*, '(A)') FILNAM ! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = FULLNAME + IF (LEN_TRIM(FILNAM) == 0) FILNAM = FULLNAME ! - 1 CONTINUE - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 2 CONTINUE + 1 CONTINUE + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 2 CONTINUE WRITE (ISTDE, *) 'Enter a name for the GENMCP SUMmary', & - ' File that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 2 - GO TO 1 - ENDIF + ' File that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 2 + GO TO 1 + ENDIF ! - RETURN - END SUBROUTINE SETSUM + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rangular90/setsum_I.f90 b/src/appl/rangular90/setsum_I.f90 index 235106170..fc0f398b1 100644 --- a/src/appl/rangular90/setsum_I.f90 +++ b/src/appl/rangular90/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (FULLNAME) - CHARACTER (LEN = *), INTENT(IN) :: FULLNAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (FULLNAME) + CHARACTER (LEN = *), INTENT(IN) :: FULLNAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/settmpGG.f90 b/src/appl/rangular90/settmpGG.f90 index 0e294cc15..75c9081d2 100644 --- a/src/appl/rangular90/settmpGG.f90 +++ b/src/appl/rangular90/settmpGG.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETTMPGG(NB, K, FILEHEAD) + SUBROUTINE SETTMPGG(NB, K, FILEHEAD) !*********************************************************************** ! Modified by Gediminas Gaigalas: Feb 2017 * ! 1) for new spin-angular integration, * @@ -9,8 +9,8 @@ SUBROUTINE SETTMPGG(NB, K, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- @@ -18,14 +18,14 @@ SUBROUTINE SETTMPGG(NB, K, FILEHEAD) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NB - INTEGER, INTENT(IN) :: K - CHARACTER, INTENT(IN) :: FILEHEAD*(*) + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(IN) :: K + CHARACTER, INTENT(IN) :: FILEHEAD*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LCK, IERR, LNG - CHARACTER :: CK*2 + INTEGER :: LCK, IERR, LNG + CHARACTER :: CK*2 !----------------------------------------------- ! ! All files filehead.XX are UNFORMATTED; diff --git a/src/appl/rangular90/settmpGG_I.f90 b/src/appl/rangular90/settmpGG_I.f90 index a9f4a788d..c9cd7dff0 100644 --- a/src/appl/rangular90/settmpGG_I.f90 +++ b/src/appl/rangular90/settmpGG_I.f90 @@ -1,9 +1,9 @@ - MODULE settmpgg_I + MODULE settmpgg_I INTERFACE - SUBROUTINE settmpgg (NB, K, FILEHEAD) - INTEGER, INTENT(IN) :: NB + SUBROUTINE settmpgg (NB, K, FILEHEAD) + INTEGER, INTENT(IN) :: NB INTEGER, INTENT(IN) :: K - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD - END SUBROUTINE - END INTERFACE - END MODULE + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/sort.f90 b/src/appl/rangular90/sort.f90 index c30a87ecd..3d7dfecfd 100644 --- a/src/appl/rangular90/sort.f90 +++ b/src/appl/rangular90/sort.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) + SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! * ! This routine sorts lists * ! * @@ -19,44 +19,44 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! Written by Farid A. Parpia Last revision: 21 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE ORB_C, ONLY: NP, NCF, NH - USE IOUNIT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NFILE - INTEGER :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL - INTEGER, INTENT(IN) :: NB - LOGICAL, INTENT(IN) :: LPRINT - CHARACTER, INTENT(IN) :: FHEAD*(*) + INTEGER :: NFILE + INTEGER :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL + INTEGER, INTENT(IN) :: NB + LOGICAL, INTENT(IN) :: LPRINT + CHARACTER, INTENT(IN) :: FHEAD*(*) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP - REAL(DOUBLE), DIMENSION(:), pointer :: COEFF + INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP + REAL(DOUBLE), DIMENSION(:), pointer :: COEFF INTEGER :: LCNUM, LCK, IERR, MB, I, L, IR, ICL, IND, LAB, NSW, J,& - LAST, IBEG, IEND, NCONTR, IA, IB, K, ID, IC - REAL(DOUBLE) :: COF - CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 + LAST, IBEG, IEND, NCONTR, IA, IB, K, ID, IC + REAL(DOUBLE) :: COF + CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 CHARACTER (LEN = LEN (fhead) + 3):: fullname !----------------------------------------------- ! @@ -71,41 +71,41 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! ! Message ! - CALL CONVRT (NCOEFF, CNUM, LCNUM) - IF (NFILE > 31) THEN - CALL CONVRT (NFILE - 32, CK, LCK) + CALL CONVRT (NCOEFF, CNUM, LCNUM) + IF (NFILE > 31) THEN + CALL CONVRT (NFILE - 32, CK, LCK) WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' V(k='//CK(1:LCK)//& - ') coefficients ...', NFILE - ELSE - WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE - ENDIF -! - CALL CONVRT (NFILE, CK, LCK) - IF (LCK > 2) THEN - WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' - STOP - ENDIF - - FULLNAME = FHEAD//'.'//CK(1:2) - + ') coefficients ...', NFILE + ELSE + WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE + ENDIF +! + CALL CONVRT (NFILE, CK, LCK) + IF (LCK > 2) THEN + WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' + STOP + ENDIF + + FULLNAME = FHEAD//'.'//CK(1:2) + OPEN(29,FILE=FULLNAME,STATUS='OLD',FORM='UNFORMATTED', & - IOSTAT=IERR, POSITION='APPEND') - IF (IERR /= 0) THEN - WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME - STOP - ENDIF - + IOSTAT=IERR, POSITION='APPEND') + IF (IERR /= 0) THEN + WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME + STOP + ENDIF + ! IF (NFILE.EQ.33) REWIND (20) - - READ (NFILE) MCPLAB, MB - IF (NB /= MB) THEN - WRITE (ISTDE, *) 'sort: nb = ', NB, '.NE. mb (=', MB, ')' - STOP - ENDIF + + READ (NFILE) MCPLAB, MB + IF (NB /= MB) THEN + WRITE (ISTDE, *) 'sort: nb = ', NB, '.NE. mb (=', MB, ')' + STOP + ENDIF ! ! Sort the list ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! ! Allocate storage for all required arrays ! @@ -114,203 +114,203 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) CALL ALLOC (INDEX, NCOEFF, 'INDEX', 'SORT') CALL ALLOC (LABEL, NCOEFF, 'LABEL', 'SORT') - IF (NFILE == 33) CALL ALLOC (NSWAP, NCOEFF,'NSWAP', 'SORT' ) + IF (NFILE == 33) CALL ALLOC (NSWAP, NCOEFF,'NSWAP', 'SORT' ) ! ! Read arrays into memory from NFILE ! - DO I = 1, NCOEFF - READ (NFILE) ICLMN(I), INDEX(I), LABEL(I), COEFF(I) - END DO - + DO I = 1, NCOEFF + READ (NFILE) ICLMN(I), INDEX(I), LABEL(I), COEFF(I) + END DO + ! IF (NFILE.EQ.33) THEN ! DO 11 I = 1,NCOEFF ! READ (20) NSWAP(I) ! 11 CONTINUE ! ENDIF ! - ENDIF + ENDIF ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - IF (NFILE==33 .AND. NCOEFF>1) THEN - - L = NCOEFF/2 + 1 - IR = NCOEFF - 234 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L) - ICL = ICLMN(L) - IND = INDEX(L) - LAB = LABEL(L) - NSW = NSWAP(L) - ELSE - COF = COEFF(IR) - ICL = ICLMN(IR) - IND = INDEX(IR) - LAB = LABEL(IR) - NSW = NSWAP(IR) - COEFF(IR) = COEFF(1) - ICLMN(IR) = ICLMN(1) - INDEX(IR) = INDEX(1) - LABEL(IR) = LABEL(1) - NSWAP(IR) = NSWAP(1) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1) = COF - ICLMN(1) = ICL - INDEX(1) = IND - LABEL(1) = LAB - NSWAP(1) = NSW - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 345 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J) < LABEL(J+1)) J = J + 1 - ENDIF - IF (LAB < LABEL(J)) THEN - COEFF(I) = COEFF(J) - ICLMN(I) = ICLMN(J) - INDEX(I) = INDEX(J) - LABEL(I) = LABEL(J) - NSWAP(I) = NSWAP(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 345 - ENDIF - COEFF(I) = COF - ICLMN(I) = ICL - INDEX(I) = IND - LABEL(I) = LAB - NSWAP(I) = NSW - GO TO 234 - - ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN + IF (NFILE==33 .AND. NCOEFF>1) THEN + + L = NCOEFF/2 + 1 + IR = NCOEFF + 234 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L) + ICL = ICLMN(L) + IND = INDEX(L) + LAB = LABEL(L) + NSW = NSWAP(L) + ELSE + COF = COEFF(IR) + ICL = ICLMN(IR) + IND = INDEX(IR) + LAB = LABEL(IR) + NSW = NSWAP(IR) + COEFF(IR) = COEFF(1) + ICLMN(IR) = ICLMN(1) + INDEX(IR) = INDEX(1) + LABEL(IR) = LABEL(1) + NSWAP(IR) = NSWAP(1) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1) = COF + ICLMN(1) = ICL + INDEX(1) = IND + LABEL(1) = LAB + NSWAP(1) = NSW + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 345 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J) < LABEL(J+1)) J = J + 1 + ENDIF + IF (LAB < LABEL(J)) THEN + COEFF(I) = COEFF(J) + ICLMN(I) = ICLMN(J) + INDEX(I) = INDEX(J) + LABEL(I) = LABEL(J) + NSWAP(I) = NSWAP(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 345 + ENDIF + COEFF(I) = COF + ICLMN(I) = ICL + INDEX(I) = IND + LABEL(I) = LAB + NSWAP(I) = NSW + GO TO 234 + + ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - L = NCOEFF/2 + 1 - IR = NCOEFF - 92 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L) - ICL = ICLMN(L) - IND = INDEX(L) - LAB = LABEL(L) - ELSE - COF = COEFF(IR) - ICL = ICLMN(IR) - IND = INDEX(IR) - LAB = LABEL(IR) - COEFF(IR) = COEFF(1) - ICLMN(IR) = ICLMN(1) - INDEX(IR) = INDEX(1) - LABEL(IR) = LABEL(1) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1) = COF - ICLMN(1) = ICL - INDEX(1) = IND - LABEL(1) = LAB - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 93 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J) < LABEL(J+1)) J = J + 1 - ENDIF - IF (LAB < LABEL(J)) THEN - COEFF(I) = COEFF(J) - ICLMN(I) = ICLMN(J) - INDEX(I) = INDEX(J) - LABEL(I) = LABEL(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 93 - ENDIF - COEFF(I) = COF - ICLMN(I) = ICL - INDEX(I) = IND - LABEL(I) = LAB - GO TO 92 - - ENDIF + L = NCOEFF/2 + 1 + IR = NCOEFF + 92 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L) + ICL = ICLMN(L) + IND = INDEX(L) + LAB = LABEL(L) + ELSE + COF = COEFF(IR) + ICL = ICLMN(IR) + IND = INDEX(IR) + LAB = LABEL(IR) + COEFF(IR) = COEFF(1) + ICLMN(IR) = ICLMN(1) + INDEX(IR) = INDEX(1) + LABEL(IR) = LABEL(1) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1) = COF + ICLMN(1) = ICL + INDEX(1) = IND + LABEL(1) = LAB + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 93 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J) < LABEL(J+1)) J = J + 1 + ENDIF + IF (LAB < LABEL(J)) THEN + COEFF(I) = COEFF(J) + ICLMN(I) = ICLMN(J) + INDEX(I) = INDEX(J) + LABEL(I) = LABEL(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 93 + ENDIF + COEFF(I) = COF + ICLMN(I) = ICL + INDEX(I) = IND + LABEL(I) = LAB + GO TO 92 + + ENDIF ! ! Sorting complete; rewrite the file header ! ! - 456 CONTINUE - WRITE (29) 'MCP', NB, NCF, NCOEFF + 456 CONTINUE + WRITE (29) 'MCP', NB, NCF, NCOEFF !GG WRITE (9999,*) 'MCP', NB, NCF, NCOEFF, NFILE ! ! Write the sorted list to mcp.xx ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! - LAST = LABEL(1) - IBEG = 1 - IEND = 1 - NTGRAL = 1 + LAST = LABEL(1) + IBEG = 1 + IEND = 1 + NTGRAL = 1 ! - DO I = 2, NCOEFF - IF (LABEL(I) == LAST) THEN - IEND = IEND + 1 - ELSE - WRITE (29) LAST, IEND - IBEG + 1 -!GG WRITE (9999,*) LAST, IEND - IBEG + 1 - WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,IEND) + DO I = 2, NCOEFF + IF (LABEL(I) == LAST) THEN + IEND = IEND + 1 + ELSE + WRITE (29) LAST, IEND - IBEG + 1 +!GG WRITE (9999,*) LAST, IEND - IBEG + 1 + WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,IEND) !cjb-GG DO J = IBEG,IEND !GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) !cjb-GG END DO - + ! IF (NFILE.EQ.33) WRITE (20) (NSWAP(J),J = IBEG,IEND) - NTGRAL = NTGRAL + 1 - LAST = LABEL(I) - IBEG = IEND + 1 - IEND = IBEG - ENDIF - END DO -! - IF (IBEG <= NCOEFF) THEN - WRITE (29) LAST, NCOEFF - IBEG + 1 -!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 - WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,NCOEFF) + NTGRAL = NTGRAL + 1 + LAST = LABEL(I) + IBEG = IEND + 1 + IEND = IBEG + ENDIF + END DO +! + IF (IBEG <= NCOEFF) THEN + WRITE (29) LAST, NCOEFF - IBEG + 1 +!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 + WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,NCOEFF) DO J=IBEG,NCOEFF -!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) +!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) END DO - + ! IF (NFILE.EQ.33) WRITE (20) (NSWAP(J),J = IBEG,NCOEFF) - ENDIF + ENDIF ! - ELSE + ELSE ! - NTGRAL = 0 + NTGRAL = 0 ! - ENDIF + ENDIF ! ! write the terminator record for this block ! - WRITE (29) 0, 0 -!GG WRITE (9999,*) 0, 0 - CLOSE(29) + WRITE (29) 0, 0 +!GG WRITE (9999,*) 0, 0 + CLOSE(29) ! ! Completion message ! @@ -318,68 +318,68 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! ! Debug printout ! - IF (LPRINT) THEN - WRITE (99, 300) - WRITE (6, 300) - IF (NCOEFF > 0) THEN -! - LAST = LABEL(1) - IBEG = 1 - IEND = 1 -! - DO I = 2, NCOEFF - IF (LABEL(I) == LAST) IEND = IEND + 1 - 567 CONTINUE - IF (LABEL(I)==LAST .AND. I/=NCOEFF) CYCLE - LAB = LAST - NCONTR = IEND - IBEG + 1 - IF (NFILE == 31) THEN - IA = MOD(LAB,KEY) - IB = LAB/KEY - WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) - DO J = IBEG, IEND - WRITE (99, 302) ICLMN(J), INDEX(J), COEFF(J) - END DO - ELSE - K = NFILE - 32 - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY + IF (LPRINT) THEN + WRITE (99, 300) + WRITE (6, 300) + IF (NCOEFF > 0) THEN +! + LAST = LABEL(1) + IBEG = 1 + IEND = 1 +! + DO I = 2, NCOEFF + IF (LABEL(I) == LAST) IEND = IEND + 1 + 567 CONTINUE + IF (LABEL(I)==LAST .AND. I/=NCOEFF) CYCLE + LAB = LAST + NCONTR = IEND - IBEG + 1 + IF (NFILE == 31) THEN + IA = MOD(LAB,KEY) + IB = LAB/KEY + WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) + DO J = IBEG, IEND + WRITE (99, 302) ICLMN(J), INDEX(J), COEFF(J) + END DO + ELSE + K = NFILE - 32 + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY WRITE (99, 304) K, NP(IA), NH(IA), NP(IB), NH(IB), NP(IC), NH& - (IC), NP(ID), NH(ID) - DO J = IBEG, IEND - WRITE (99, 305) K, ICLMN(J), INDEX(J), COEFF(J) - END DO - ENDIF - LAST = LABEL(I) - IBEG = IEND + 1 - IEND = IBEG - IF (IEND == NCOEFF) GO TO 567 - END DO - ENDIF - WRITE (99, 303) NTGRAL - ENDIF + (IC), NP(ID), NH(ID) + DO J = IBEG, IEND + WRITE (99, 305) K, ICLMN(J), INDEX(J), COEFF(J) + END DO + ENDIF + LAST = LABEL(I) + IBEG = IEND + 1 + IEND = IBEG + IF (IEND == NCOEFF) GO TO 567 + END DO + ENDIF + WRITE (99, 303) NTGRAL + ENDIF ! ! Deallocate storage ! - IF (NCOEFF > 0) THEN - CALL DALLOC (COEFF,'COEFF', 'SORT') - CALL DALLOC (ICLMN, 'ICLMN', 'SORT') - CALL DALLOC (INDEX, 'INDEX', 'SORT') - CALL DALLOC (LABEL, 'LABEL', 'SORT') - IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORT') - ENDIF - - 300 FORMAT(/,'From SORT:') - 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') - 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) - 303 FORMAT(' Number of integrals is ',1I4) + IF (NCOEFF > 0) THEN + CALL DALLOC (COEFF,'COEFF', 'SORT') + CALL DALLOC (ICLMN, 'ICLMN', 'SORT') + CALL DALLOC (INDEX, 'INDEX', 'SORT') + CALL DALLOC (LABEL, 'LABEL', 'SORT') + IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORT') + ENDIF + + 300 FORMAT(/,'From SORT:') + 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') + 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) + 303 FORMAT(' Number of integrals is ',1I4) 304 FORMAT(' R^[(',1I2,')] (',1I2,1A2,',',1I2,1A2,';',1I2,1A2,',',1I2,1A2,& - '):') - 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) - - RETURN - END SUBROUTINE SORT + '):') + 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) + + RETURN + END SUBROUTINE SORT diff --git a/src/appl/rangular90/sort_I.f90 b/src/appl/rangular90/sort_I.f90 index a0cb4298d..c8e2126bc 100644 --- a/src/appl/rangular90/sort_I.f90 +++ b/src/appl/rangular90/sort_I.f90 @@ -1,15 +1,15 @@ - MODULE sort_I + MODULE sort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE sort (NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL - LOGICAL, INTENT(IN) :: LPRINT - INTEGER, INTENT(IN) :: NB - CHARACTER (LEN = *), INTENT(IN) :: FHEAD - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE sort (NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL + LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NB + CHARACTER (LEN = *), INTENT(IN) :: FHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/sortmem.f90 b/src/appl/rangular90/sortmem.f90 index aabe49e3f..e9936c501 100644 --- a/src/appl/rangular90/sortmem.f90 +++ b/src/appl/rangular90/sortmem.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SORTMEM(NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) + SUBROUTINE SORTMEM(NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) ! * ! This routine sorts lists * ! * @@ -19,44 +19,44 @@ SUBROUTINE SORTMEM(NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) ! Written by Farid A. Parpia Last revision: 21 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE ORB_C, ONLY: NP, NCF, NH - USE IOUNIT_C + USE IOUNIT_C USE sacoef_C, COEFF=>TCOEFF,LABEL=>ILABEL,ICLMN=>IICLMN,INDEX=>IINDEX !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NFILE - INTEGER :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL + INTEGER :: NFILE + INTEGER :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL INTEGER, INTENT(IN) :: NB,IGGMAX_K - LOGICAL, INTENT(IN) :: LPRINT - CHARACTER, INTENT(IN) :: FHEAD*(*) + LOGICAL, INTENT(IN) :: LPRINT + CHARACTER, INTENT(IN) :: FHEAD*(*) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- -! INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP +! INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP INTEGER, DIMENSION(:), pointer :: NSWAP -! REAL(DOUBLE), DIMENSION(:), pointer :: COEFF +! REAL(DOUBLE), DIMENSION(:), pointer :: COEFF INTEGER :: LCNUM, LCK, IERR, MB, I, L, IR, ICL, IND, LAB, NSW, J,& LAST, IBEG, IEND, NCONTR, IA, IB, K, ID, IC, IGG - REAL(DOUBLE) :: COF - CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 + REAL(DOUBLE) :: COF + CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 CHARACTER (LEN = LEN (fhead) + 3):: fullname !----------------------------------------------- ! @@ -68,222 +68,222 @@ SUBROUTINE SORTMEM(NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) ! IGG = IGGMAX_K*(IGG-1) ! Message ! - CALL CONVRT (NCOEFF, CNUM, LCNUM) - IF (NFILE > 31) THEN - CALL CONVRT (NFILE - 32, CK, LCK) + CALL CONVRT (NCOEFF, CNUM, LCNUM) + IF (NFILE > 31) THEN + CALL CONVRT (NFILE - 32, CK, LCK) WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' V(k='//CK(1:LCK)//& - ') coefficients ...', NFILE - ELSE - WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE - ENDIF -! - CALL CONVRT (NFILE, CK, LCK) - IF (LCK > 2) THEN - WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' - STOP - ENDIF - - FULLNAME = FHEAD//'.'//CK(1:2) - + ') coefficients ...', NFILE + ELSE + WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE + ENDIF +! + CALL CONVRT (NFILE, CK, LCK) + IF (LCK > 2) THEN + WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' + STOP + ENDIF + + FULLNAME = FHEAD//'.'//CK(1:2) + OPEN(29,FILE=FULLNAME,STATUS='OLD',FORM='UNFORMATTED', & - IOSTAT=IERR, POSITION='APPEND') - IF (IERR /= 0) THEN - WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME - STOP - ENDIF + IOSTAT=IERR, POSITION='APPEND') + IF (IERR /= 0) THEN + WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME + STOP + ENDIF ! ! Sort the list ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! ! Allocate storage for all required arrays ! IF (NFILE == 33) CALL ALLOC (NSWAP, NCOEFF,'NSWAP', 'SORTMEM') - ENDIF + ENDIF ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - IF (NFILE==33 .AND. NCOEFF>1) THEN - - L = NCOEFF/2 + 1 - IR = NCOEFF - 234 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L,IGG) - ICL = ICLMN(L,IGG) - IND = INDEX(L,IGG) - LAB = LABEL(L,IGG) - NSW = NSWAP(L) - ELSE - COF = COEFF(IR,IGG) - ICL = ICLMN(IR,IGG) - IND = INDEX(IR,IGG) - LAB = LABEL(IR,IGG) - NSW = NSWAP(IR) - COEFF(IR,IGG) = COEFF(1,IGG) - ICLMN(IR,IGG) = ICLMN(1,IGG) - INDEX(IR,IGG) = INDEX(1,IGG) - LABEL(IR,IGG) = LABEL(1,IGG) - NSWAP(IR) = NSWAP(1) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1,IGG) = COF - ICLMN(1,IGG) = ICL - INDEX(1,IGG) = IND - LABEL(1,IGG) = LAB - NSWAP(1) = NSW - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 345 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J,IGG) < LABEL(J+1,IGG)) J = J + 1 - ENDIF - IF (LAB < LABEL(J,IGG)) THEN - COEFF(I,IGG) = COEFF(J,IGG) - ICLMN(I,IGG) = ICLMN(J,IGG) - INDEX(I,IGG) = INDEX(J,IGG) - LABEL(I,IGG) = LABEL(J,IGG) - NSWAP(I) = NSWAP(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 345 - ENDIF - COEFF(I,IGG) = COF - ICLMN(I,IGG) = ICL - INDEX(I,IGG) = IND - LABEL(I,IGG) = LAB - NSWAP(I) = NSW - GO TO 234 - - ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN + IF (NFILE==33 .AND. NCOEFF>1) THEN + + L = NCOEFF/2 + 1 + IR = NCOEFF + 234 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L,IGG) + ICL = ICLMN(L,IGG) + IND = INDEX(L,IGG) + LAB = LABEL(L,IGG) + NSW = NSWAP(L) + ELSE + COF = COEFF(IR,IGG) + ICL = ICLMN(IR,IGG) + IND = INDEX(IR,IGG) + LAB = LABEL(IR,IGG) + NSW = NSWAP(IR) + COEFF(IR,IGG) = COEFF(1,IGG) + ICLMN(IR,IGG) = ICLMN(1,IGG) + INDEX(IR,IGG) = INDEX(1,IGG) + LABEL(IR,IGG) = LABEL(1,IGG) + NSWAP(IR) = NSWAP(1) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1,IGG) = COF + ICLMN(1,IGG) = ICL + INDEX(1,IGG) = IND + LABEL(1,IGG) = LAB + NSWAP(1) = NSW + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 345 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J,IGG) < LABEL(J+1,IGG)) J = J + 1 + ENDIF + IF (LAB < LABEL(J,IGG)) THEN + COEFF(I,IGG) = COEFF(J,IGG) + ICLMN(I,IGG) = ICLMN(J,IGG) + INDEX(I,IGG) = INDEX(J,IGG) + LABEL(I,IGG) = LABEL(J,IGG) + NSWAP(I) = NSWAP(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 345 + ENDIF + COEFF(I,IGG) = COF + ICLMN(I,IGG) = ICL + INDEX(I,IGG) = IND + LABEL(I,IGG) = LAB + NSWAP(I) = NSW + GO TO 234 + + ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - L = NCOEFF/2 + 1 - IR = NCOEFF - 92 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L,IGG) - ICL = ICLMN(L,IGG) - IND = INDEX(L,IGG) - LAB = LABEL(L,IGG) - ELSE - COF = COEFF(IR,IGG) - ICL = ICLMN(IR,IGG) - IND = INDEX(IR,IGG) - LAB = LABEL(IR,IGG) - COEFF(IR,IGG) = COEFF(1,IGG) - ICLMN(IR,IGG) = ICLMN(1,IGG) - INDEX(IR,IGG) = INDEX(1,IGG) - LABEL(IR,IGG) = LABEL(1,IGG) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1,IGG) = COF - ICLMN(1,IGG) = ICL - INDEX(1,IGG) = IND - LABEL(1,IGG) = LAB - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 93 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J,IGG) < LABEL(J+1,IGG)) J = J + 1 - ENDIF - IF (LAB < LABEL(J,IGG)) THEN - COEFF(I,IGG) = COEFF(J,IGG) - ICLMN(I,IGG) = ICLMN(J,IGG) - INDEX(I,IGG) = INDEX(J,IGG) - LABEL(I,IGG) = LABEL(J,IGG) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 93 - ENDIF - COEFF(I,IGG) = COF - ICLMN(I,IGG) = ICL - INDEX(I,IGG) = IND - LABEL(I,IGG) = LAB - GO TO 92 - - ENDIF + L = NCOEFF/2 + 1 + IR = NCOEFF + 92 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L,IGG) + ICL = ICLMN(L,IGG) + IND = INDEX(L,IGG) + LAB = LABEL(L,IGG) + ELSE + COF = COEFF(IR,IGG) + ICL = ICLMN(IR,IGG) + IND = INDEX(IR,IGG) + LAB = LABEL(IR,IGG) + COEFF(IR,IGG) = COEFF(1,IGG) + ICLMN(IR,IGG) = ICLMN(1,IGG) + INDEX(IR,IGG) = INDEX(1,IGG) + LABEL(IR,IGG) = LABEL(1,IGG) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1,IGG) = COF + ICLMN(1,IGG) = ICL + INDEX(1,IGG) = IND + LABEL(1,IGG) = LAB + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 93 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J,IGG) < LABEL(J+1,IGG)) J = J + 1 + ENDIF + IF (LAB < LABEL(J,IGG)) THEN + COEFF(I,IGG) = COEFF(J,IGG) + ICLMN(I,IGG) = ICLMN(J,IGG) + INDEX(I,IGG) = INDEX(J,IGG) + LABEL(I,IGG) = LABEL(J,IGG) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 93 + ENDIF + COEFF(I,IGG) = COF + ICLMN(I,IGG) = ICL + INDEX(I,IGG) = IND + LABEL(I,IGG) = LAB + GO TO 92 + + ENDIF ! ! Sorting complete; rewrite the file header ! ! - 456 CONTINUE - WRITE (29) 'MCP', NB, NCF, NCOEFF + 456 CONTINUE + WRITE (29) 'MCP', NB, NCF, NCOEFF !GG WRITE (9999,*) 'MCP', NB, NCF, NCOEFF, NFILE ! ! Write the sorted list to mcp.xx ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! - LAST = LABEL(1,IGG) - IBEG = 1 - IEND = 1 - NTGRAL = 1 + LAST = LABEL(1,IGG) + IBEG = 1 + IEND = 1 + NTGRAL = 1 ! - DO I = 2, NCOEFF - IF (LABEL(I,IGG) == LAST) THEN - IEND = IEND + 1 - ELSE - WRITE (29) LAST, IEND - IBEG + 1 -!GG WRITE (9999,*) LAST, IEND - IBEG + 1 + DO I = 2, NCOEFF + IF (LABEL(I,IGG) == LAST) THEN + IEND = IEND + 1 + ELSE + WRITE (29) LAST, IEND - IBEG + 1 +!GG WRITE (9999,*) LAST, IEND - IBEG + 1 WRITE (29) (ICLMN(J,IGG),INDEX(J,IGG),COEFF(J,IGG), & - J=IBEG,IEND) + J=IBEG,IEND) !cjb-GG DO J = IBEG,IEND !GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) !cjb-GG END DO - + ! IF (NFILE.EQ.33) WRITE (20) (NSWAP(J),J = IBEG,IEND) - NTGRAL = NTGRAL + 1 - LAST = LABEL(I,IGG) - IBEG = IEND + 1 - IEND = IBEG - ENDIF - END DO -! - IF (IBEG <= NCOEFF) THEN - WRITE (29) LAST, NCOEFF - IBEG + 1 -!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 + NTGRAL = NTGRAL + 1 + LAST = LABEL(I,IGG) + IBEG = IEND + 1 + IEND = IBEG + ENDIF + END DO +! + IF (IBEG <= NCOEFF) THEN + WRITE (29) LAST, NCOEFF - IBEG + 1 +!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 WRITE (29) (ICLMN(J,IGG),INDEX(J,IGG),COEFF(J,IGG), & - J=IBEG,NCOEFF) + J=IBEG,NCOEFF) !GG DO J=IBEG,NCOEFF -!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) +!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) !GG END DO - + ! IF (NFILE.EQ.33) WRITE (20) (NSWAP(J),J = IBEG,NCOEFF) - ENDIF + ENDIF ! - ELSE + ELSE ! - NTGRAL = 0 + NTGRAL = 0 ! - ENDIF + ENDIF ! ! write the terminator record for this block ! - WRITE (29) 0, 0 -!GG WRITE (9999,*) 0, 0 - CLOSE(29) + WRITE (29) 0, 0 +!GG WRITE (9999,*) 0, 0 + CLOSE(29) ! ! Completion message ! @@ -291,66 +291,66 @@ SUBROUTINE SORTMEM(NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) ! ! Debug printout ! - IF (LPRINT) THEN - WRITE (99, 300) - WRITE (6, 300) - IF (NCOEFF > 0) THEN -! - LAST = LABEL(1,IGG) - IBEG = 1 - IEND = 1 -! - DO I = 2, NCOEFF - IF (LABEL(I,IGG) == LAST) IEND = IEND + 1 - 567 CONTINUE - IF (LABEL(I,IGG)==LAST .AND. I/=NCOEFF) CYCLE - LAB = LAST - NCONTR = IEND - IBEG + 1 - IF (NFILE == 31) THEN - IA = MOD(LAB,KEY) - IB = LAB/KEY - WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) - DO J = IBEG, IEND + IF (LPRINT) THEN + WRITE (99, 300) + WRITE (6, 300) + IF (NCOEFF > 0) THEN +! + LAST = LABEL(1,IGG) + IBEG = 1 + IEND = 1 +! + DO I = 2, NCOEFF + IF (LABEL(I,IGG) == LAST) IEND = IEND + 1 + 567 CONTINUE + IF (LABEL(I,IGG)==LAST .AND. I/=NCOEFF) CYCLE + LAB = LAST + NCONTR = IEND - IBEG + 1 + IF (NFILE == 31) THEN + IA = MOD(LAB,KEY) + IB = LAB/KEY + WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) + DO J = IBEG, IEND WRITE (99, 302) ICLMN(J,IGG),INDEX(J,IGG), & - COEFF(J,IGG) - END DO - ELSE - K = NFILE - 32 - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY + COEFF(J,IGG) + END DO + ELSE + K = NFILE - 32 + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY WRITE (99, 304) K, NP(IA), NH(IA), NP(IB), NH(IB), NP(IC), NH& - (IC), NP(ID), NH(ID) - DO J = IBEG, IEND + (IC), NP(ID), NH(ID) + DO J = IBEG, IEND WRITE (99, 305) K,ICLMN(J,IGG),INDEX(J,IGG), & COEFF(J,IGG) - END DO - ENDIF - LAST = LABEL(I,IGG) - IBEG = IEND + 1 - IEND = IBEG - IF (IEND == NCOEFF) GO TO 567 - END DO - ENDIF - WRITE (99, 303) NTGRAL - ENDIF + END DO + ENDIF + LAST = LABEL(I,IGG) + IBEG = IEND + 1 + IEND = IBEG + IF (IEND == NCOEFF) GO TO 567 + END DO + ENDIF + WRITE (99, 303) NTGRAL + ENDIF ! ! Deallocate storage ! - IF (NCOEFF > 0) THEN - IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORTMEM') - ENDIF - - 300 FORMAT(/,'From SORT:') - 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') - 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) - 303 FORMAT(' Number of integrals is ',1I4) + IF (NCOEFF > 0) THEN + IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORTMEM') + ENDIF + + 300 FORMAT(/,'From SORT:') + 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') + 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) + 303 FORMAT(' Number of integrals is ',1I4) 304 FORMAT(' R^[(',1I2,')] (',1I2,1A2,',',1I2,1A2,';',1I2,1A2,',',1I2,1A2,& - '):') - 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) - - RETURN + '):') + 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) + + RETURN END SUBROUTINE SORTMEM diff --git a/src/appl/rangular90/sortmem_I.f90 b/src/appl/rangular90/sortmem_I.f90 index 0a7d074c3..49f9fd562 100644 --- a/src/appl/rangular90/sortmem_I.f90 +++ b/src/appl/rangular90/sortmem_I.f90 @@ -1,12 +1,12 @@ - MODULE sortmem_I + MODULE sortmem_I INTERFACE SUBROUTINE sortmem (NFILE,IGGMAX_K,NCOEFF,NTGRAL,LPRINT,NB,FHEAD) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL - LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL + LOGICAL, INTENT(IN) :: LPRINT INTEGER, INTENT(IN) :: NB,IGGMAX_K - CHARACTER (LEN = *), INTENT(IN) :: FHEAD - END SUBROUTINE - END INTERFACE - END MODULE + CHARACTER (LEN = *), INTENT(IN) :: FHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90/strsum.f90 b/src/appl/rangular90/strsum.f90 index def65b6d1..b0ee73bc2 100644 --- a/src/appl/rangular90/strsum.f90 +++ b/src/appl/rangular90/strsum.f90 @@ -1,13 +1,13 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM - + SUBROUTINE STRSUM + !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- Use hblock_C USE def_C @@ -17,49 +17,49 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE calen_I - USE convrt_I + USE calen_I + USE convrt_I !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, I - Character :: CTIME*10, CDATE*8 - CHARACTER :: RECORD*256, CDATA*26 + INTEGER :: LENTH, I + Character :: CTIME*10, CDATE*8 + CHARACTER :: RECORD*256, CDATA*26 !----------------------------------------------- ! ! ! Get the date and time of day; make this information the ! header of the summary file ! - CALL CALEN (CTIME, CDATE) - WRITE (24, *) 'GENMCP run at ', CTIME, ' on ', CDATE, '.' + CALL CALEN (CTIME, CDATE) + WRITE (24, *) 'GENMCP run at ', CTIME, ' on ', CDATE, '.' ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (DIAG) THEN - WRITE (24, *) - WRITE (24, *) 'Only diagonal matrix elements are computed.' - ELSE - IF (LFORDR) THEN - DO I = 1, NBLOCK - WRITE (24, *) - CALL CONVRT (ICCUT(I), RECORD, LENTH) + IF (DIAG) THEN + WRITE (24, *) + WRITE (24, *) 'Only diagonal matrix elements are computed.' + ELSE + IF (LFORDR) THEN + DO I = 1, NBLOCK + WRITE (24, *) + CALL CONVRT (ICCUT(I), RECORD, LENTH) WRITE (24, *) 'CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space.' - END DO - ENDIF - ENDIF + ' the zero-order space.' + END DO + ENDIF + ENDIF ! - RETURN - END SUBROUTINE STRSUM + RETURN + END SUBROUTINE STRSUM diff --git a/src/appl/rangular90/strsum_I.f90 b/src/appl/rangular90/strsum_I.f90 index d2cba577b..afcf67e39 100644 --- a/src/appl/rangular90/strsum_I.f90 +++ b/src/appl/rangular90/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/Makefile b/src/appl/rangular90_mpi/Makefile index b143a0bcd..f46126d6e 100644 --- a/src/appl/rangular90_mpi/Makefile +++ b/src/appl/rangular90_mpi/Makefile @@ -31,7 +31,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - ${LAPACK_LIBS} + ${LAPACK_LIBS} .f90.o: $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I $(MODL9290) -I $(MODLRANG90) -I $(MODLMCP90) -I ${MODDIR} -I $(MODLMPIU90) -o $@ @@ -42,4 +42,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rangular90_mpi/fndbeg.f90 b/src/appl/rangular90_mpi/fndbeg.f90 index 06327eef1..f39aa7e76 100644 --- a/src/appl/rangular90_mpi/fndbeg.f90 +++ b/src/appl/rangular90_mpi/fndbeg.f90 @@ -1,12 +1,12 @@ !*********************************************************************** ! * - SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) + SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- @@ -18,17 +18,17 @@ SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: JASTRT - INTEGER, INTENT(INOUT) :: JBSTRT - INTEGER, INTENT(INOUT) :: INDEX - INTEGER, INTENT(OUT) :: LLISTT + INTEGER, INTENT(INOUT) :: JASTRT + INTEGER, INTENT(INOUT) :: JBSTRT + INTEGER, INTENT(INOUT) :: INDEX + INTEGER, INTENT(OUT) :: LLISTT INTEGER, DIMENSION(:), pointer :: LLISTV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IOS, ICREAD, IRREAD, INDX, NREC, I, LABEL - REAL(DOUBLE) :: COEFF - CHARACTER :: SRTLAB*8, MCPLAB*3 + INTEGER :: K, IOS, ICREAD, IRREAD, INDX, NREC, I, LABEL + REAL(DOUBLE) :: COEFF + CHARACTER :: SRTLAB*8, MCPLAB*3 !----------------------------------------------- ! ! Begin by examining file 30; this is the last to be updated by @@ -36,91 +36,91 @@ SUBROUTINE FNDBEG(JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) ! ! Read and check the character part of the file header ! - REWIND (30) - READ (30) MCPLAB, SRTLAB - IF (SRTLAB == ' SORTED') THEN - JASTRT = NCF + 1 - JBSTRT = NCF + 1 - LLISTT = 0 - LLISTV(:KMAX) = 0 - GO TO 8 - ENDIF + REWIND (30) + READ (30) MCPLAB, SRTLAB + IF (SRTLAB == ' SORTED') THEN + JASTRT = NCF + 1 + JBSTRT = NCF + 1 + LLISTT = 0 + LLISTV(:KMAX) = 0 + GO TO 8 + ENDIF ! - READ (30) - READ (30) + READ (30) + READ (30) ! ! Read as many records as possible ! - 2 CONTINUE - READ (30, IOSTAT=IOS) ICREAD, IRREAD, INDX + 2 CONTINUE + READ (30, IOSTAT=IOS) ICREAD, IRREAD, INDX ! - IF (IOS == 0) THEN + IF (IOS == 0) THEN ! ! No errors or end-of-file; keep reading ! - JASTRT = ICREAD - JBSTRT = IRREAD - INDEX = INDX - GO TO 2 + JASTRT = ICREAD + JBSTRT = IRREAD + INDEX = INDX + GO TO 2 ! - ELSE + ELSE ! - IF (JASTRT==NCF .AND. JBSTRT==NCF) THEN + IF (JASTRT==NCF .AND. JBSTRT==NCF) THEN ! ! All coefficients have been generated; sorting may still ! be necessary; force this option ! - JASTRT = NCF + 1 - JBSTRT = NCF + 1 + JASTRT = NCF + 1 + JBSTRT = NCF + 1 ! - ELSE + ELSE ! ! Some coefficients remain to be generated; reposition all files ! for augmentation of lists by SUBROUTINE MCP; update JBSTRT and, ! if appropriate, JASTRT ! - DO K = 31, 32 + KMAX - REWIND (K) - NREC = 3 - DO I = 1, NREC - READ (K) - END DO - 4 CONTINUE - READ (K, IOSTAT=IOS) INDX, LABEL, COEFF - IF (IOS==0 .AND. INDX<=INDEX) THEN - NREC = NREC + 1 - GO TO 4 - ELSE - REWIND (K) - DO I = 1, NREC - READ (K) - END DO - IF (K > 31) THEN - LLISTV(K-32) = NREC - 3 - ELSE - LLISTT = NREC - 3 - ENDIF - ENDIF - END DO + DO K = 31, 32 + KMAX + REWIND (K) + NREC = 3 + DO I = 1, NREC + READ (K) + END DO + 4 CONTINUE + READ (K, IOSTAT=IOS) INDX, LABEL, COEFF + IF (IOS==0 .AND. INDX<=INDEX) THEN + NREC = NREC + 1 + GO TO 4 + ELSE + REWIND (K) + DO I = 1, NREC + READ (K) + END DO + IF (K > 31) THEN + LLISTV(K-32) = NREC - 3 + ELSE + LLISTT = NREC - 3 + ENDIF + ENDIF + END DO ! ! Now, reposition the sms file. This file should contain the ! same number of data records as file 33. - - REWIND (20) - DO I = 1, LLISTV(1) - READ (20) - END DO - - JBSTRT = JBSTRT + 1 - IF (JBSTRT > NCF) THEN - JASTRT = JASTRT + 1 - JBSTRT = JASTRT - ENDIF -! - ENDIF -! - ENDIF -! - 8 CONTINUE - RETURN - END SUBROUTINE FNDBEG + + REWIND (20) + DO I = 1, LLISTV(1) + READ (20) + END DO + + JBSTRT = JBSTRT + 1 + IF (JBSTRT > NCF) THEN + JASTRT = JASTRT + 1 + JBSTRT = JASTRT + ENDIF +! + ENDIF +! + ENDIF +! + 8 CONTINUE + RETURN + END SUBROUTINE FNDBEG diff --git a/src/appl/rangular90_mpi/fndbeg_I.f90 b/src/appl/rangular90_mpi/fndbeg_I.f90 index c60274fcc..cd1f76f4e 100644 --- a/src/appl/rangular90_mpi/fndbeg_I.f90 +++ b/src/appl/rangular90_mpi/fndbeg_I.f90 @@ -1,14 +1,14 @@ - MODULE fndbeg_I + MODULE fndbeg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fndbeg (JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) - INTEGER, INTENT(INOUT) :: JASTRT - INTEGER, INTENT(INOUT) :: JBSTRT - INTEGER, INTENT(INOUT) :: INDEX - INTEGER, INTENT(OUT) :: LLISTT + SUBROUTINE fndbeg (JASTRT, JBSTRT, INDEX, LLISTT, LLISTV) + INTEGER, INTENT(INOUT) :: JASTRT + INTEGER, INTENT(INOUT) :: JBSTRT + INTEGER, INTENT(INOUT) :: INDEX + INTEGER, INTENT(OUT) :: LLISTT INTEGER, DIMENSION(:), pointer :: LLISTV - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/genmcpmpi.f90 b/src/appl/rangular90_mpi/genmcpmpi.f90 index d442d2b01..d9e8bfa7f 100644 --- a/src/appl/rangular90_mpi/genmcpmpi.f90 +++ b/src/appl/rangular90_mpi/genmcpmpi.f90 @@ -25,13 +25,13 @@ PROGRAM GENMCPMPI ! * ! Written by Farid A. Parpia Last revision: 11 Dec 1992 * ! MPI version by Xinghong He Last revision: 29 Jun 1998 * -! Updated by Charlotte F. Fischer +! Updated by Charlotte F. Fischer ! * ! Modified by Gediminas Gaigalas for new spin-angular integration. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- USE parameter_def, ONLY: NNNW @@ -49,21 +49,21 @@ PROGRAM GENMCPMPI !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbg_I - USE setmc_I - USE setsum_I - USE cslh_I - USE strsum_I - USE factt_I - USE settmp_I + USE getyn_I + USE setdbg_I + USE setmc_I + USE setsum_I + USE cslh_I + USE strsum_I + USE factt_I + USE settmp_I USE lodcslmpi_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER NBLK0, NCOUNT1, NCORE, NB - PARAMETER (NBLK0 = 50) + PARAMETER (NBLK0 = 50) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -86,7 +86,7 @@ PROGRAM GENMCPMPI lenperm = LEN_TRIM (permdir) lentmp = LEN_TRIM (tmpdir) !======================================================================= -! Get NDEF on node-0 and then send to all nodes +! Get NDEF on node-0 and then send to all nodes !======================================================================= IF (myid == 0) THEN WRITE (istde,*) @@ -116,47 +116,47 @@ PROGRAM GENMCPMPI ! strsum - append a summary of the inputs to the .sum file ! factt - table of logarithms of factorials setup !======================================================================= - + CALL setdbgmpi (DEBUG, permdir(1:lenperm) // '/genmcp.dbg') - CALL SETMC + CALL SETMC if(myid == 0) file_rcsl = permdir(1:lenperm)//'/rcsf.inp' - CALL cslhmpi (file_rcsl, ncore, nblk0, idblk) - RESTRT = .FALSE. + CALL cslhmpi (file_rcsl, ncore, nblk0, idblk) + RESTRT = .FALSE. !cjb myid, nprocs = NOT args !cjb CALL setmcpmpi (myid, nprocs, ncore, idblk, 'mcp' // idstring) - CALL setmcpmpi (ncore, idblk, 'mcp' // idstring) - IF (NDEF/=0 .AND. MYID==0) CALL STRSUM - CALL FACTT - + CALL setmcpmpi (ncore, idblk, 'mcp' // idstring) + IF (NDEF/=0 .AND. MYID==0) CALL STRSUM + CALL FACTT + !======================================================================= ! For each block, generate and sort the data !======================================================================= - - DO NB = 1, NBLOCK - NCF = NCFBLK(NB) ! This ncf goes to common - IF (MYID == 0) THEN - WRITE (6, *) - WRITE (6, *) 'Block ', NB, ', ncf = ', NCF - ENDIF + + DO NB = 1, NBLOCK + NCF = NCFBLK(NB) ! This ncf goes to common + IF (MYID == 0) THEN + WRITE (6, *) + WRITE (6, *) 'Block ', NB, ', ncf = ', NCF + ENDIF !*** Load current CSL block. Memories de-allocated in mcp *** CALL ALLOC (iqa, NNNW, NCF, 'IQA', 'GENMCP') CALL ALLOC (jqsa, NNNW,3,NCF, 'JQSA', 'GENMCP') CALL ALLOC (jcupa, NNNW, NCF, 'JCUPA', 'GENMCP') ! - CALL LODCSLmpi (21, NCORE, NB) + CALL LODCSLmpi (21, NCORE, NB) !*** Open tmp.xx files for block nb *** - CALL SETTMP (NB, KMAX, 'tmp' // idstring) + CALL SETTMP (NB, KMAX, 'tmp' // idstring) !*** Generation of MCP coefficients *** !cjb myid, nprocs = NOT args !cjb CALL MCPmpi (NB, RESTRT, MYID, NPROCS, 'mcp' // idstring) - CALL MCPmpi (NB, RESTRT, 'mcp' // idstring) - END DO - CLOSE(24) ! Summary file + CALL MCPmpi (NB, RESTRT, 'mcp' // idstring) + END DO + CLOSE(24) ! Summary file CLOSE(739) ! rangular.log - IF (DEBUG) CLOSE(99) ! Debug file + IF (DEBUG) CLOSE(99) ! Debug file !======================================================================= ! Execution finished; Statistics output !======================================================================= CALL stopmpi2 (myid,nprocs,host,lenhost,ncount1,'RANGULAR_MPI') - STOP + STOP END PROGRAM GENMCPMPI diff --git a/src/appl/rangular90_mpi/getinf.f90 b/src/appl/rangular90_mpi/getinf.f90 index 49b81e4eb..18ec260eb 100644 --- a/src/appl/rangular90_mpi/getinf.f90 +++ b/src/appl/rangular90_mpi/getinf.f90 @@ -15,8 +15,8 @@ SUBROUTINE GETINF ! Updated to treat ICCUT for block * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rangular90_mpi/getinf_I.f90 b/src/appl/rangular90_mpi/getinf_I.f90 index 78b2f8424..bf4b087ec 100644 --- a/src/appl/rangular90_mpi/getinf_I.f90 +++ b/src/appl/rangular90_mpi/getinf_I.f90 @@ -1,9 +1,9 @@ - MODULE getinf_I + MODULE getinf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getinf - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getinf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/mcpmpi_gg.f90 b/src/appl/rangular90_mpi/mcpmpi_gg.f90 index 4b6896888..c158842e4 100644 --- a/src/appl/rangular90_mpi/mcpmpi_gg.f90 +++ b/src/appl/rangular90_mpi/mcpmpi_gg.f90 @@ -24,8 +24,8 @@ SUBROUTINE mcpmpi (nb, RESTRT, fhead) ! integration 01 April 2012 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -46,7 +46,7 @@ SUBROUTINE mcpmpi (nb, RESTRT, fhead) !----------------------------------------------- ! C O M M O N B L O C K S !----------------------------------------------- - USE BUFFER_C, ONLY: NVCOEF, LABEL, COEFF + USE BUFFER_C, ONLY: NVCOEF, LABEL, COEFF USE DEBUG_C, ONLY: LDBPA USE DEFAULT_C, ONLY: NDEF USE iccu_C, ONLY: ICCUT diff --git a/src/appl/rangular90_mpi/mcpmpi_gg_I.f90 b/src/appl/rangular90_mpi/mcpmpi_gg_I.f90 index c856fc5cb..348b03a55 100644 --- a/src/appl/rangular90_mpi/mcpmpi_gg_I.f90 +++ b/src/appl/rangular90_mpi/mcpmpi_gg_I.f90 @@ -1,7 +1,7 @@ MODULE mcpmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !cjb myid, nprocs = NOT args SUBROUTINE mcpmpi (nb, RESTRT, fhead) diff --git a/src/appl/rangular90_mpi/outsdampi.f90 b/src/appl/rangular90_mpi/outsdampi.f90 index 8aeed5678..eb19f5c3e 100644 --- a/src/appl/rangular90_mpi/outsdampi.f90 +++ b/src/appl/rangular90_mpi/outsdampi.f90 @@ -1,20 +1,20 @@ -!*********************************************************************** - SUBROUTINE OUTSDAMPI(LPRINT,NNONZ, NCF) -!*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!*********************************************************************** + SUBROUTINE OUTSDAMPI(LPRINT,NNONZ, NCF) +!*********************************************************************** +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- USE mpi_C - IMPLICIT NONE + IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NNONZ - INTEGER, INTENT(IN) :: NCF - LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NNONZ + INTEGER, INTENT(IN) :: NCF + LOGICAL, INTENT(IN) :: LPRINT !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- @@ -22,27 +22,27 @@ SUBROUTINE OUTSDAMPI(LPRINT,NNONZ, NCF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NNONZ_A + INTEGER :: NNONZ_A !----------------------------------------------- ! CALL MPI_Reduce (nnonz, nnonz_a, 1, MPI_INTEGER, MPI_SUM, 0, & MPI_COMM_WORLD, ierr) IF (myid .EQ. 0) & WRITE(6, *)' ... complete; density of non-zero elements of H(DC):', & - NNONZ_A, '/', (NCF*(NCF + 1))/2 + NNONZ_A, '/', (NCF*(NCF + 1))/2 ! ! Debug printout ! - IF (LPRINT) THEN + IF (LPRINT) THEN IF (myid .EQ. 0) THEN - WRITE (99, *) - WRITE (99, *) 'From ', MYNAME, ' :' - WRITE (99, 301) NNONZ_A - WRITE (6, *) 'This part not finished. See ', MYNAME - WRITE (99, *) 'This part not finished. See ', MYNAME - ENDIF - ENDIF - 301 FORMAT(' Number of nonzero elements in H(DC): ',1I4) - 302 FORMAT(' Column ',1I2,', row ',1I2,', sparse matrix index ',1I4) - RETURN - END SUBROUTINE OUTSDAMPI + WRITE (99, *) + WRITE (99, *) 'From ', MYNAME, ' :' + WRITE (99, 301) NNONZ_A + WRITE (6, *) 'This part not finished. See ', MYNAME + WRITE (99, *) 'This part not finished. See ', MYNAME + ENDIF + ENDIF + 301 FORMAT(' Number of nonzero elements in H(DC): ',1I4) + 302 FORMAT(' Column ',1I2,', row ',1I2,', sparse matrix index ',1I4) + RETURN + END SUBROUTINE OUTSDAMPI diff --git a/src/appl/rangular90_mpi/outsdampi_I.f90 b/src/appl/rangular90_mpi/outsdampi_I.f90 index 34b5131dd..f6d219c87 100644 --- a/src/appl/rangular90_mpi/outsdampi_I.f90 +++ b/src/appl/rangular90_mpi/outsdampi_I.f90 @@ -1,12 +1,12 @@ - MODULE outsdampi_I + MODULE outsdampi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE outsdampi (LPRINT, NNONZ, NCF) - LOGICAL, INTENT(IN) :: LPRINT - INTEGER, INTENT(IN) :: NNONZ - INTEGER, INTENT(IN) :: NCF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE outsdampi (LPRINT, NNONZ, NCF) + LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NNONZ + INTEGER, INTENT(IN) :: NCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/setdbg.f90 b/src/appl/rangular90_mpi/setdbg.f90 index a73859ad6..f1266c0aa 100644 --- a/src/appl/rangular90_mpi/setdbg.f90 +++ b/src/appl/rangular90_mpi/setdbg.f90 @@ -53,7 +53,7 @@ SUBROUTINE SETDBG (DEBUG, fullname) IF (NDEF .EQ. 0) THEN RETURN ENDIF - + WRITE (istde,*) 'Generate debug printout?' DEBUG = GETYN () IF (DEBUG) THEN @@ -95,7 +95,7 @@ SUBROUTINE SETDBG (DEBUG, fullname) LDBPA(3) = GETYN () WRITE (istde,*) ' Print out sparse matrix definition arrays?' LDBPA(4) = GETYN () - + ENDIF ! RETURN diff --git a/src/appl/rangular90_mpi/setdbg_I.f90 b/src/appl/rangular90_mpi/setdbg_I.f90 index 6575c6e57..8cce54973 100644 --- a/src/appl/rangular90_mpi/setdbg_I.f90 +++ b/src/appl/rangular90_mpi/setdbg_I.f90 @@ -1,7 +1,7 @@ MODULE SETDBG_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETDBG (DEBUG, fullname) LOGICAL :: DEBUG diff --git a/src/appl/rangular90_mpi/setdbgmpi.f90 b/src/appl/rangular90_mpi/setdbgmpi.f90 index 807af12b7..12e5d704e 100644 --- a/src/appl/rangular90_mpi/setdbgmpi.f90 +++ b/src/appl/rangular90_mpi/setdbgmpi.f90 @@ -9,7 +9,7 @@ SUBROUTINE SETDBGmpi (DEBUG, fullname) ! * !*********************************************************************** !...Translated by Pacific-Sierra Research 77to90 4.3E 11:11:16 12/23/06 -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rangular90_mpi/setdbgmpi_I.f90 b/src/appl/rangular90_mpi/setdbgmpi_I.f90 index 1b5f07a69..df9b61f71 100644 --- a/src/appl/rangular90_mpi/setdbgmpi_I.f90 +++ b/src/appl/rangular90_mpi/setdbgmpi_I.f90 @@ -1,7 +1,7 @@ MODULE SETDBGmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETDBGmpi (DEBUG, fullname) LOGICAL :: DEBUG diff --git a/src/appl/rangular90_mpi/setmcp.f90 b/src/appl/rangular90_mpi/setmcp.f90 index 88725aa22..8a5d4b555 100644 --- a/src/appl/rangular90_mpi/setmcp.f90 +++ b/src/appl/rangular90_mpi/setmcp.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * !cjb myid, nprocs = NOT args - SUBROUTINE SETMCP(NCORE, IDBLK, FILEHEAD) + SUBROUTINE SETMCP(NCORE, IDBLK, FILEHEAD) ! * ! Open and check the .mcp files. File 30 stores the structure of * ! H(DC) ; file 31 stores the T coefficients; files 32, 33, ..., * @@ -16,8 +16,8 @@ SUBROUTINE SETMCP(NCORE, IDBLK, FILEHEAD) ! Used by mcpvu, mcpmpivu ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! C o m m o n B l o c k s @@ -29,58 +29,58 @@ SUBROUTINE SETMCP(NCORE, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I USE mpi_C, ONLY: MYID, NPROCS, IERR IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- -! INTEGER, INTENT(IN) :: MYID -! INTEGER, INTENT(IN) :: NPROCS - INTEGER, INTENT(IN) :: NCORE - CHARACTER, INTENT(IN) :: FILEHEAD*(*) - CHARACTER, INTENT(IN) :: IDBLK(*)*8 +! INTEGER, INTENT(IN) :: MYID +! INTEGER, INTENT(IN) :: NPROCS + INTEGER, INTENT(IN) :: NCORE + CHARACTER, INTENT(IN) :: FILEHEAD*(*) + CHARACTER, INTENT(IN) :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, LNG, LCK, I - LOGICAL :: FOUND, FOUND1, GETYN, YES - CHARACTER :: CK*2 + INTEGER :: K, LNG, LCK, I + LOGICAL :: FOUND, FOUND1, GETYN, YES + CHARACTER :: CK*2 !----------------------------------------------- ! Determine KMAX; this is the number of .mcp files for the ! two-electron integrals - - KMAX = 0 - DO K = 1, NW - KMAX = MAX(KMAX,NKJ(K)) - END DO - + + KMAX = 0 + DO K = 1, NW + KMAX = MAX(KMAX,NKJ(K)) + END DO + ! All files mcp.xx are UNFORMATTED; - - LNG = LEN_TRIM(FILEHEAD) - DO K = 30, 32 + KMAX - CALL CONVRT (K, CK, LCK) + + LNG = LEN_TRIM(FILEHEAD) + DO K = 30, 32 + KMAX + CALL CONVRT (K, CK, LCK) CALL OPENFL (K, FILEHEAD(1:LNG)//'.'//CK(1:2), 'UNFORMATTED', & - 'UNKNOWN', IERR) - IF (IERR == 0) CYCLE - DO I = 30, K - CLOSE(I) - END DO - WRITE (ISTDE, *) 'Error when opening the mcp files' - STOP - END DO + 'UNKNOWN', IERR) + IF (IERR == 0) CYCLE + DO I = 30, K + CLOSE(I) + END DO + WRITE (ISTDE, *) 'Error when opening the mcp files' + STOP + END DO ! ! We want to know kmax before openning other mcp files (not mcp.30) ! in rscf ! - WRITE (30) NCORE, NBLOCK, KMAX - WRITE (30) (NCFBLK(I),I=1,NBLOCK) - WRITE (30) (IDBLK(I),I=1,NBLOCK) - - DO K = 30, 32 + KMAX - WRITE (K) 'MCP', NBLOCK, MYID, NPROCS - END DO - - RETURN - END SUBROUTINE SETMCP + WRITE (30) NCORE, NBLOCK, KMAX + WRITE (30) (NCFBLK(I),I=1,NBLOCK) + WRITE (30) (IDBLK(I),I=1,NBLOCK) + + DO K = 30, 32 + KMAX + WRITE (K) 'MCP', NBLOCK, MYID, NPROCS + END DO + + RETURN + END SUBROUTINE SETMCP diff --git a/src/appl/rangular90_mpi/setmcp_I.f90 b/src/appl/rangular90_mpi/setmcp_I.f90 index c2f208966..b05c5e566 100644 --- a/src/appl/rangular90_mpi/setmcp_I.f90 +++ b/src/appl/rangular90_mpi/setmcp_I.f90 @@ -1,16 +1,16 @@ - MODULE setmcp_I + MODULE setmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !cjb myid, nprocs = NOT args - SUBROUTINE setmcp (NCORE, IDBLK, FILEHEAD) -! INTEGER, INTENT(IN) :: MYID -! INTEGER, INTENT(IN) :: NPROCS - INTEGER, INTENT(IN) :: NCORE - CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + SUBROUTINE setmcp (NCORE, IDBLK, FILEHEAD) +! INTEGER, INTENT(IN) :: MYID +! INTEGER, INTENT(IN) :: NPROCS + INTEGER, INTENT(IN) :: NCORE + CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/setmcpmpi.f90 b/src/appl/rangular90_mpi/setmcpmpi.f90 index 9f6264f32..6114946be 100644 --- a/src/appl/rangular90_mpi/setmcpmpi.f90 +++ b/src/appl/rangular90_mpi/setmcpmpi.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * !cjb myid, nprocs = NOT args - SUBROUTINE SETMCPmpi(NCORE, IDBLK, FILEHEAD) + SUBROUTINE SETMCPmpi(NCORE, IDBLK, FILEHEAD) ! * ! A wrapper for setmcp/getinf. setmcp/getinf are then shared by serial * ! and MPI programs. * @@ -9,11 +9,11 @@ SUBROUTINE SETMCPmpi(NCORE, IDBLK, FILEHEAD) ! Written by Xinghong He Last revision: 30 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- !cjb mpi_C ! USE mpi_C, ONLY: MYID, NPROCS, ierr @@ -30,18 +30,18 @@ SUBROUTINE SETMCPmpi(NCORE, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setmcp_I + USE setmcp_I ! USE setmcpmpi_I - USE getinf_I + USE getinf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- ! INTEGER , INTENT(IN) :: MYID -! INTEGER , INTENT(IN) :: NPROCS - INTEGER , INTENT(IN) :: NCORE - CHARACTER , INTENT(IN) :: FILEHEAD*(*) - CHARACTER , INTENT(IN) :: IDBLK(*)*8 +! INTEGER , INTENT(IN) :: NPROCS + INTEGER , INTENT(IN) :: NCORE + CHARACTER , INTENT(IN) :: FILEHEAD*(*) + CHARACTER , INTENT(IN) :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -70,6 +70,6 @@ SUBROUTINE SETMCPmpi(NCORE, IDBLK, FILEHEAD) DO K = 30, 32+KMAX CLOSE (K) ENDDO - - RETURN + + RETURN END SUBROUTINE SETMCPmpi diff --git a/src/appl/rangular90_mpi/setmcpmpi_I.f90 b/src/appl/rangular90_mpi/setmcpmpi_I.f90 index bca4a0bad..a67168529 100644 --- a/src/appl/rangular90_mpi/setmcpmpi_I.f90 +++ b/src/appl/rangular90_mpi/setmcpmpi_I.f90 @@ -1,16 +1,16 @@ - MODULE setmcpmpi_I + MODULE setmcpmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !cjb myid, nprocs = NOT args - SUBROUTINE setmcpmpi (NCORE, IDBLK, FILEHEAD) + SUBROUTINE setmcpmpi (NCORE, IDBLK, FILEHEAD) ! INTEGER , INTENT(IN) :: MYID -! INTEGER , INTENT(IN) :: NPROCS +! INTEGER , INTENT(IN) :: NPROCS INTEGER , INTENT(IN) :: NCORE - CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + CHARACTER (LEN = 8), DIMENSION(*), INTENT(IN) :: IDBLK + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/setsda.f90 b/src/appl/rangular90_mpi/setsda.f90 index 8d18f33e9..f9e435773 100644 --- a/src/appl/rangular90_mpi/setsda.f90 +++ b/src/appl/rangular90_mpi/setsda.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) + SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) ! * ! This routine examines lists * ! (IC,IR,npos) * @@ -16,8 +16,8 @@ SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) ! Currently shared by mcpblk, mcpmpi ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -31,61 +31,61 @@ SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE outsdampi_I + USE outsdampi_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- EXTERNAL OUTSDAdummy INTEGER, INTENT(IN) :: NNONZ - INTEGER , INTENT(IN) :: NB - INTEGER , INTENT(IN) :: MYID - INTEGER , INTENT(IN) :: NPROCS - LOGICAL :: LPRINT - CHARACTER , INTENT(IN) :: FHEAD*(*) + INTEGER , INTENT(IN) :: NB + INTEGER , INTENT(IN) :: MYID + INTEGER , INTENT(IN) :: NPROCS + LOGICAL :: LPRINT + CHARACTER , INTENT(IN) :: FHEAD*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MB, IEND, ICLAST, I, IC, NPOS, IERR + INTEGER :: MB, IEND, ICLAST, I, IC, NPOS, IERR INTEGER, DIMENSION(:), pointer :: IENDC - INTEGER, DIMENSION(:), pointer :: IROW - CHARACTER :: MCPLAB*3 + INTEGER, DIMENSION(:), pointer :: IROW + CHARACTER :: MCPLAB*3 !----------------------------------------------- - + IF (MYID == 0) WRITE (6, *) & - 'Analysing sparse matrix array definition file ...', 30 - - READ (30) MCPLAB, MB - IF (NB /= MB) THEN - WRITE (ISTDE, *) 'setsda: nb = ', NB, '.NE. mb (=', MB, ')' - STOP - ENDIF + 'Analysing sparse matrix array definition file ...', 30 + + READ (30) MCPLAB, MB + IF (NB /= MB) THEN + WRITE (ISTDE, *) 'setsda: nb = ', NB, '.NE. mb (=', MB, ')' + STOP + ENDIF ! !cjb PRINT *, ' setsda.f90 FHEAD ' !cjb PRINT *, ' setsda.f90 FHEAD = ', FHEAD ! Allocate storage for IENDC(0:NCF) ! - CALL ALLOC (IENDC, 0, NCF,'IENDC','SETSDA' ) - CALL ALLOC (IROW, NNONZ, 'IROW', 'SETSDA' ) + CALL ALLOC (IENDC, 0, NCF,'IENDC','SETSDA' ) + CALL ALLOC (IROW, NNONZ, 'IROW', 'SETSDA' ) ! ! Analyse data on file 30; set up IENDC and IROW ! In multiprocessor environment, iendc of each node will have the ! same length (ncf+1); but will have its own part filled. irow is ! local, and its length is determined by the local parameter nnonz. - - IEND = 0 - ICLAST = 0 - DO I = 1, NNONZ - READ (30) IC, IROW(I), NPOS - IF (IC /= ICLAST) THEN - IENDC(ICLAST) = IEND - ICLAST = IC - ENDIF - IEND = NPOS - END DO + + IEND = 0 + ICLAST = 0 + DO I = 1, NNONZ + READ (30) IC, IROW(I), NPOS + IF (IC /= ICLAST) THEN + IENDC(ICLAST) = IEND + ICLAST = IC + ENDIF + IEND = NPOS + END DO !xhh - changed to suits MPI environment as well ! IENDC(NCF) = IEND - IENDC(IC) = IEND + IENDC(IC) = IEND ! ! Sorting complete; rewrite to mcpXXX.30 file ! @@ -93,24 +93,24 @@ SUBROUTINE SETSDA(OUTSDAdummy,NNONZ,LPRINT,NB,MYID,NPROCS,FHEAD) !cjb PRINT *, ' FHEAD = ', FHEAD !cjb PRINT *, ' before OPEN ' OPEN(29, FILE=FHEAD//'.30', STATUS='OLD', FORM='UNFORMATTED', IOSTAT=IERR& - , POSITION='APPEND') + , POSITION='APPEND') !cjb PRINT *, ' after OPEN ' - IF (IERR /= 0) THEN - WRITE (ISTDE, *) ' Error when opening the file mcp.30' - STOP - ENDIF - - WRITE (29) 'MCP', NB, NCF - WRITE (29) NNONZ - WRITE (29) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NNONZ) - CLOSE(29) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) ' Error when opening the file mcp.30' + STOP + ENDIF + + WRITE (29) 'MCP', NB, NCF + WRITE (29) NNONZ + WRITE (29) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NNONZ) + CLOSE(29) !cjb ! ! Deallocate storage ! - CALL DALLOC (IENDC, 'IENDC', 'SETSDA') - CALL DALLOC (IROW, 'IROW', 'SETSDA') + CALL DALLOC (IENDC, 'IENDC', 'SETSDA') + CALL DALLOC (IROW, 'IROW', 'SETSDA') ! CALL OUTSDAdummy (LPRINT, NNONZ, NCF) - RETURN - END SUBROUTINE SETSDA + RETURN + END SUBROUTINE SETSDA diff --git a/src/appl/rangular90_mpi/setsda_I.f90 b/src/appl/rangular90_mpi/setsda_I.f90 index a084be32d..1aec7ab7b 100644 --- a/src/appl/rangular90_mpi/setsda_I.f90 +++ b/src/appl/rangular90_mpi/setsda_I.f90 @@ -1,16 +1,16 @@ - MODULE setsda_I + MODULE setsda_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:52:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE setsda (OUTSDA, NNONZ, LPRINT, NB, MYID, NPROCS, FHEAD) - EXTERNAL OUTSDA - INTEGER, INTENT(IN) :: NNONZ - LOGICAL :: LPRINT - INTEGER, INTENT(IN) :: NB - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - CHARACTER (LEN = *), INTENT(IN) :: FHEAD - END SUBROUTINE - END INTERFACE - END MODULE + EXTERNAL OUTSDA + INTEGER, INTENT(IN) :: NNONZ + LOGICAL :: LPRINT + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + CHARACTER (LEN = *), INTENT(IN) :: FHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/setsum.f90 b/src/appl/rangular90_mpi/setsum.f90 index 6d68ec2d4..f0b6d02e6 100644 --- a/src/appl/rangular90_mpi/setsum.f90 +++ b/src/appl/rangular90_mpi/setsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSUM(FULLNAME) + SUBROUTINE SETSUM(FULLNAME) ! * ! Open the .sum file on stream 24. * ! * @@ -12,18 +12,18 @@ SUBROUTINE SETSUM(FULLNAME) ! File shared by mcpblk, mcpmpi ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE IOUNIT_C + USE vast_kind_param, ONLY: DOUBLE + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -32,33 +32,33 @@ SUBROUTINE SETSUM(FULLNAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR + INTEGER :: IERR CHARACTER(LEN=120) :: FILNAM ! The original did not compile CHARACTER(LEN=11) :: FORM CHARACTER(LEN=3) :: STATUS !----------------------------------------------- - FORM = 'FORMATTED' - STATUS = 'NEW' + FORM = 'FORMATTED' + STATUS = 'NEW' ! WRITE (ISTDE, *) 'File ', FULLNAME, ' will be created as the', & - ' GENMCP SUMmary File;' + ' GENMCP SUMmary File;' WRITE (ISTDE, *) 'enter another file name if this is not ', & - 'acceptable; null otherwise:' - READ (*, '(A)') FILNAM + 'acceptable; null otherwise:' + READ (*, '(A)') FILNAM ! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = FULLNAME + IF (LEN_TRIM(FILNAM) == 0) FILNAM = FULLNAME ! - 1 CONTINUE - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 2 CONTINUE + 1 CONTINUE + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 2 CONTINUE WRITE (ISTDE, *) 'Enter a name for the GENMCP SUMmary', & - ' File that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 2 - GO TO 1 - ENDIF + ' File that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 2 + GO TO 1 + ENDIF ! - RETURN - END SUBROUTINE SETSUM + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rangular90_mpi/setsum_I.f90 b/src/appl/rangular90_mpi/setsum_I.f90 index 235106170..fc0f398b1 100644 --- a/src/appl/rangular90_mpi/setsum_I.f90 +++ b/src/appl/rangular90_mpi/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:54:22 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (FULLNAME) - CHARACTER (LEN = *), INTENT(IN) :: FULLNAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (FULLNAME) + CHARACTER (LEN = *), INTENT(IN) :: FULLNAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/settmp.f90 b/src/appl/rangular90_mpi/settmp.f90 index c4beab590..bf70cc9f2 100644 --- a/src/appl/rangular90_mpi/settmp.f90 +++ b/src/appl/rangular90_mpi/settmp.f90 @@ -1,15 +1,15 @@ !*********************************************************************** ! * - SUBROUTINE SETTMP(NB, KMAX, FILEHEAD) + SUBROUTINE SETTMP(NB, KMAX, FILEHEAD) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- @@ -17,34 +17,34 @@ SUBROUTINE SETTMP(NB, KMAX, FILEHEAD) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NB - INTEGER , INTENT(IN) :: KMAX - CHARACTER , INTENT(IN) :: FILEHEAD*(*) + INTEGER , INTENT(IN) :: NB + INTEGER , INTENT(IN) :: KMAX + CHARACTER , INTENT(IN) :: FILEHEAD*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, LCK, IERR, I, LNG - CHARACTER :: CK*2 + INTEGER :: K, LCK, IERR, I, LNG + CHARACTER :: CK*2 !----------------------------------------------- ! ! All files filehead.XX are UNFORMATTED; ! - LNG = LEN_TRIM(FILEHEAD) - DO K = 30, 32 + KMAX - CALL CONVRT (K, CK, LCK) + LNG = LEN_TRIM(FILEHEAD) + DO K = 30, 32 + KMAX + CALL CONVRT (K, CK, LCK) CALL OPENFL (K, FILEHEAD(1:LNG)//'.'//CK(1:2), 'UNFORMATTED', & - 'UNKNOWN', IERR) - IF (IERR == 0) CYCLE - DO I = 30, K - CLOSE(I) - END DO - WRITE (ISTDE, *) 'Error when opening the tmp files' - STOP - END DO - - DO K = 30, 32 + KMAX - WRITE (K) 'MCP', NB - END DO - - RETURN - END SUBROUTINE SETTMP + 'UNKNOWN', IERR) + IF (IERR == 0) CYCLE + DO I = 30, K + CLOSE(I) + END DO + WRITE (ISTDE, *) 'Error when opening the tmp files' + STOP + END DO + + DO K = 30, 32 + KMAX + WRITE (K) 'MCP', NB + END DO + + RETURN + END SUBROUTINE SETTMP diff --git a/src/appl/rangular90_mpi/settmp_I.f90 b/src/appl/rangular90_mpi/settmp_I.f90 index 21bf3bbbb..9098acbfd 100644 --- a/src/appl/rangular90_mpi/settmp_I.f90 +++ b/src/appl/rangular90_mpi/settmp_I.f90 @@ -1,12 +1,12 @@ - MODULE settmp_I + MODULE settmp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE settmp (NB, KMAX, FILEHEAD) - INTEGER, INTENT(IN) :: NB - INTEGER, INTENT(IN) :: KMAX - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE settmp (NB, KMAX, FILEHEAD) + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(IN) :: KMAX + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/sort.f90 b/src/appl/rangular90_mpi/sort.f90 index aaaef0afa..c49482713 100644 --- a/src/appl/rangular90_mpi/sort.f90 +++ b/src/appl/rangular90_mpi/sort.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) + SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! * ! This routine sorts lists * ! * @@ -19,79 +19,79 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! Written by Farid A. Parpia Last revision: 21 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE ORB_C, ONLY: NP, NCF, NH - USE IOUNIT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NFILE - INTEGER :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL - INTEGER, INTENT(IN) :: NB - LOGICAL, INTENT(IN) :: LPRINT - CHARACTER, INTENT(IN) :: FHEAD*(*) + INTEGER :: NFILE + INTEGER :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL + INTEGER, INTENT(IN) :: NB + LOGICAL, INTENT(IN) :: LPRINT + CHARACTER, INTENT(IN) :: FHEAD*(*) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP - REAL(DOUBLE), DIMENSION(:), pointer :: COEFF + INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, LABEL, NSWAP + REAL(DOUBLE), DIMENSION(:), pointer :: COEFF INTEGER :: LCNUM, LCK, IERR, MB, I, L, IR, ICL, IND, LAB, NSW, J,& - LAST, IBEG, IEND, NCONTR, IA, IB, K, ID, IC - REAL(DOUBLE) :: COF - CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 + LAST, IBEG, IEND, NCONTR, IA, IB, K, ID, IC + REAL(DOUBLE) :: COF + CHARACTER :: CNUM*20, SRTLAB*8, MCPLAB*3, CK*2 CHARACTER (LEN = LEN (fhead) + 3):: fullname !----------------------------------------------- ! - CALL CONVRT (NCOEFF, CNUM, LCNUM) - IF (NFILE > 31) THEN - CALL CONVRT (NFILE - 32, CK, LCK) + CALL CONVRT (NCOEFF, CNUM, LCNUM) + IF (NFILE > 31) THEN + CALL CONVRT (NFILE - 32, CK, LCK) WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' V(k='//CK(1:LCK)//& - ') coefficients ...', NFILE - ELSE - WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE - ENDIF -! - CALL CONVRT (NFILE, CK, LCK) - IF (LCK > 2) THEN - WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' - STOP - ENDIF -! - FULLNAME = FHEAD//'.'//CK(1:2) + ') coefficients ...', NFILE + ELSE + WRITE (6, *) 'Sorting '//CNUM(1:LCNUM)//' T coefficients ...', NFILE + ENDIF +! + CALL CONVRT (NFILE, CK, LCK) + IF (LCK > 2) THEN + WRITE (ISTDE, *) 'sort: nfile > 99; check fullname' + STOP + ENDIF +! + FULLNAME = FHEAD//'.'//CK(1:2) OPEN(29,FILE=FULLNAME,STATUS='OLD',FORM='UNFORMATTED', & - IOSTAT=IERR, POSITION='APPEND') - IF (IERR /= 0) THEN - WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME - STOP - ENDIF -! - READ (NFILE) MCPLAB, MB - IF (NB /= MB) THEN - WRITE (ISTDE, *) 'sort: nb = ', NB, '.NE. mb (=', MB, ')' - STOP - ENDIF + IOSTAT=IERR, POSITION='APPEND') + IF (IERR /= 0) THEN + WRITE (ISTDE, *) ' Error when opening the file ', FULLNAME + STOP + ENDIF +! + READ (NFILE) MCPLAB, MB + IF (NB /= MB) THEN + WRITE (ISTDE, *) 'sort: nb = ', NB, '.NE. mb (=', MB, ')' + STOP + ENDIF ! ! Sort the list ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! ! Allocate storage for all required arrays ! @@ -99,193 +99,193 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) CALL ALLOC (ICLMN, NCOEFF, 'ICLMN', 'SORT') CALL ALLOC (INDEX, NCOEFF, 'INDEX', 'SORT') CALL ALLOC (LABEL, NCOEFF, 'LABEL', 'SORT') - IF (NFILE == 33) CALL ALLOC (NSWAP, NCOEFF,'NSWAP', 'SORT' ) + IF (NFILE == 33) CALL ALLOC (NSWAP, NCOEFF,'NSWAP', 'SORT' ) ! ! Read arrays into memory from NFILE ! - DO I = 1, NCOEFF - READ (NFILE) ICLMN(I), INDEX(I), LABEL(I), COEFF(I) - END DO - ENDIF + DO I = 1, NCOEFF + READ (NFILE) ICLMN(I), INDEX(I), LABEL(I), COEFF(I) + END DO + ENDIF ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - IF (NFILE==33 .AND. NCOEFF>1) THEN - - L = NCOEFF/2 + 1 - IR = NCOEFF - 234 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L) - ICL = ICLMN(L) - IND = INDEX(L) - LAB = LABEL(L) - NSW = NSWAP(L) - ELSE - COF = COEFF(IR) - ICL = ICLMN(IR) - IND = INDEX(IR) - LAB = LABEL(IR) - NSW = NSWAP(IR) - COEFF(IR) = COEFF(1) - ICLMN(IR) = ICLMN(1) - INDEX(IR) = INDEX(1) - LABEL(IR) = LABEL(1) - NSWAP(IR) = NSWAP(1) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1) = COF - ICLMN(1) = ICL - INDEX(1) = IND - LABEL(1) = LAB - NSWAP(1) = NSW - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 345 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J) < LABEL(J+1)) J = J + 1 - ENDIF - IF (LAB < LABEL(J)) THEN - COEFF(I) = COEFF(J) - ICLMN(I) = ICLMN(J) - INDEX(I) = INDEX(J) - LABEL(I) = LABEL(J) - NSWAP(I) = NSWAP(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 345 - ENDIF - COEFF(I) = COF - ICLMN(I) = ICL - INDEX(I) = IND - LABEL(I) = LAB - NSWAP(I) = NSW - GO TO 234 - - ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN + IF (NFILE==33 .AND. NCOEFF>1) THEN + + L = NCOEFF/2 + 1 + IR = NCOEFF + 234 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L) + ICL = ICLMN(L) + IND = INDEX(L) + LAB = LABEL(L) + NSW = NSWAP(L) + ELSE + COF = COEFF(IR) + ICL = ICLMN(IR) + IND = INDEX(IR) + LAB = LABEL(IR) + NSW = NSWAP(IR) + COEFF(IR) = COEFF(1) + ICLMN(IR) = ICLMN(1) + INDEX(IR) = INDEX(1) + LABEL(IR) = LABEL(1) + NSWAP(IR) = NSWAP(1) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1) = COF + ICLMN(1) = ICL + INDEX(1) = IND + LABEL(1) = LAB + NSWAP(1) = NSW + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 345 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J) < LABEL(J+1)) J = J + 1 + ENDIF + IF (LAB < LABEL(J)) THEN + COEFF(I) = COEFF(J) + ICLMN(I) = ICLMN(J) + INDEX(I) = INDEX(J) + LABEL(I) = LABEL(J) + NSWAP(I) = NSWAP(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 345 + ENDIF + COEFF(I) = COF + ICLMN(I) = ICL + INDEX(I) = IND + LABEL(I) = LAB + NSWAP(I) = NSW + GO TO 234 + + ELSE IF (NFILE/=33 .AND. NCOEFF>1) THEN ! ! Sort LABEL into ascending order using the heapsort algorithm; ! move the associated members of COEFF and INDEX in the same ! manner; the code below is adapted from Press et al. ! - L = NCOEFF/2 + 1 - IR = NCOEFF - 92 CONTINUE - IF (L > 1) THEN - L = L - 1 - COF = COEFF(L) - ICL = ICLMN(L) - IND = INDEX(L) - LAB = LABEL(L) - ELSE - COF = COEFF(IR) - ICL = ICLMN(IR) - IND = INDEX(IR) - LAB = LABEL(IR) - COEFF(IR) = COEFF(1) - ICLMN(IR) = ICLMN(1) - INDEX(IR) = INDEX(1) - LABEL(IR) = LABEL(1) - IR = IR - 1 - IF (IR == 1) THEN - COEFF(1) = COF - ICLMN(1) = ICL - INDEX(1) = IND - LABEL(1) = LAB - GO TO 456 - ENDIF - ENDIF - I = L - J = L + L - 93 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (LABEL(J) < LABEL(J+1)) J = J + 1 - ENDIF - IF (LAB < LABEL(J)) THEN - COEFF(I) = COEFF(J) - ICLMN(I) = ICLMN(J) - INDEX(I) = INDEX(J) - LABEL(I) = LABEL(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 93 - ENDIF - COEFF(I) = COF - ICLMN(I) = ICL - INDEX(I) = IND - LABEL(I) = LAB - GO TO 92 - - ENDIF + L = NCOEFF/2 + 1 + IR = NCOEFF + 92 CONTINUE + IF (L > 1) THEN + L = L - 1 + COF = COEFF(L) + ICL = ICLMN(L) + IND = INDEX(L) + LAB = LABEL(L) + ELSE + COF = COEFF(IR) + ICL = ICLMN(IR) + IND = INDEX(IR) + LAB = LABEL(IR) + COEFF(IR) = COEFF(1) + ICLMN(IR) = ICLMN(1) + INDEX(IR) = INDEX(1) + LABEL(IR) = LABEL(1) + IR = IR - 1 + IF (IR == 1) THEN + COEFF(1) = COF + ICLMN(1) = ICL + INDEX(1) = IND + LABEL(1) = LAB + GO TO 456 + ENDIF + ENDIF + I = L + J = L + L + 93 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (LABEL(J) < LABEL(J+1)) J = J + 1 + ENDIF + IF (LAB < LABEL(J)) THEN + COEFF(I) = COEFF(J) + ICLMN(I) = ICLMN(J) + INDEX(I) = INDEX(J) + LABEL(I) = LABEL(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 93 + ENDIF + COEFF(I) = COF + ICLMN(I) = ICL + INDEX(I) = IND + LABEL(I) = LAB + GO TO 92 + + ENDIF ! ! Sorting complete; rewrite the file header ! - 456 CONTINUE - WRITE (29) 'MCP', NB, NCF, NCOEFF + 456 CONTINUE + WRITE (29) 'MCP', NB, NCF, NCOEFF !GG WRITE (9999,*) 'MCP', NB, NCF, NCOEFF, NFILE ! ! Write the sorted list to mcp.xx ! - IF (NCOEFF > 0) THEN + IF (NCOEFF > 0) THEN ! - LAST = LABEL(1) - IBEG = 1 - IEND = 1 - NTGRAL = 1 + LAST = LABEL(1) + IBEG = 1 + IEND = 1 + NTGRAL = 1 ! - DO I = 2, NCOEFF - IF (LABEL(I) == LAST) THEN - IEND = IEND + 1 - ELSE - WRITE (29) LAST, IEND - IBEG + 1 -!GG WRITE (9999,*) LAST, IEND - IBEG + 1 - WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,IEND) + DO I = 2, NCOEFF + IF (LABEL(I) == LAST) THEN + IEND = IEND + 1 + ELSE + WRITE (29) LAST, IEND - IBEG + 1 +!GG WRITE (9999,*) LAST, IEND - IBEG + 1 + WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,IEND) !cjb-GG DO J = IBEG,IEND !GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) !cjb-GG END DO - - NTGRAL = NTGRAL + 1 - LAST = LABEL(I) - IBEG = IEND + 1 - IEND = IBEG - ENDIF - END DO -! - IF (IBEG <= NCOEFF) THEN - WRITE (29) LAST, NCOEFF - IBEG + 1 -!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 - WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,NCOEFF) + + NTGRAL = NTGRAL + 1 + LAST = LABEL(I) + IBEG = IEND + 1 + IEND = IBEG + ENDIF + END DO +! + IF (IBEG <= NCOEFF) THEN + WRITE (29) LAST, NCOEFF - IBEG + 1 +!GG WRITE (9999,*) LAST, NCOEFF - IBEG + 1 + WRITE (29) (ICLMN(J),INDEX(J),COEFF(J),J=IBEG,NCOEFF) DO J=IBEG,NCOEFF -!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) +!GG WRITE (9999,'(2I12,E25.15)') ICLMN(J),INDEX(J),COEFF(J) END DO - - ENDIF + + ENDIF ! - ELSE + ELSE ! - NTGRAL = 0 + NTGRAL = 0 ! - ENDIF + ENDIF ! ! write the terminator record for this block ! - WRITE (29) 0, 0 -!GG WRITE (9999,*) 0, 0 - CLOSE(29) + WRITE (29) 0, 0 +!GG WRITE (9999,*) 0, 0 + CLOSE(29) ! ! Completion message ! @@ -293,68 +293,68 @@ SUBROUTINE SORT(NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) ! ! Debug printout ! - IF (LPRINT) THEN - WRITE (99, 300) - WRITE (6, 300) - IF (NCOEFF > 0) THEN -! - LAST = LABEL(1) - IBEG = 1 - IEND = 1 -! - DO I = 2, NCOEFF - IF (LABEL(I) == LAST) IEND = IEND + 1 - 567 CONTINUE - IF (LABEL(I)==LAST .AND. I/=NCOEFF) CYCLE - LAB = LAST - NCONTR = IEND - IBEG + 1 - IF (NFILE == 31) THEN - IA = MOD(LAB,KEY) - IB = LAB/KEY - WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) - DO J = IBEG, IEND - WRITE (99, 302) ICLMN(J), INDEX(J), COEFF(J) - END DO - ELSE - K = NFILE - 32 - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY + IF (LPRINT) THEN + WRITE (99, 300) + WRITE (6, 300) + IF (NCOEFF > 0) THEN +! + LAST = LABEL(1) + IBEG = 1 + IEND = 1 +! + DO I = 2, NCOEFF + IF (LABEL(I) == LAST) IEND = IEND + 1 + 567 CONTINUE + IF (LABEL(I)==LAST .AND. I/=NCOEFF) CYCLE + LAB = LAST + NCONTR = IEND - IBEG + 1 + IF (NFILE == 31) THEN + IA = MOD(LAB,KEY) + IB = LAB/KEY + WRITE (99, 301) NP(IA), NH(IA), NP(IB), NH(IB) + DO J = IBEG, IEND + WRITE (99, 302) ICLMN(J), INDEX(J), COEFF(J) + END DO + ELSE + K = NFILE - 32 + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY WRITE (99, 304)K,NP(IA),NH(IA),NP(IB),NH(IB),NP(IC), & - NH(IC),NP(ID),NH(ID) - DO J = IBEG, IEND - WRITE (99, 305)K,ICLMN(J),INDEX(J),COEFF(J) - END DO - ENDIF - LAST = LABEL(I) - IBEG = IEND + 1 - IEND = IBEG - IF (IEND == NCOEFF) GO TO 567 - END DO - ENDIF - WRITE (99, 303) NTGRAL - ENDIF + NH(IC),NP(ID),NH(ID) + DO J = IBEG, IEND + WRITE (99, 305)K,ICLMN(J),INDEX(J),COEFF(J) + END DO + ENDIF + LAST = LABEL(I) + IBEG = IEND + 1 + IEND = IBEG + IF (IEND == NCOEFF) GO TO 567 + END DO + ENDIF + WRITE (99, 303) NTGRAL + ENDIF ! ! Deallocate storage ! - IF (NCOEFF > 0) THEN - CALL DALLOC (COEFF,'COEFF', 'SORT') - CALL DALLOC (ICLMN, 'ICLMN', 'SORT') - CALL DALLOC (INDEX, 'INDEX', 'SORT') - CALL DALLOC (LABEL, 'LABEL', 'SORT') - IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORT') - ENDIF - - 300 FORMAT(/,'From SORT:') - 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') - 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) - 303 FORMAT(' Number of integrals is ',1I4) + IF (NCOEFF > 0) THEN + CALL DALLOC (COEFF,'COEFF', 'SORT') + CALL DALLOC (ICLMN, 'ICLMN', 'SORT') + CALL DALLOC (INDEX, 'INDEX', 'SORT') + CALL DALLOC (LABEL, 'LABEL', 'SORT') + IF (NFILE == 33) CALL DALLOC (NSWAP, 'NSWAP', 'SORT') + ENDIF + + 300 FORMAT(/,'From SORT:') + 301 FORMAT(' I(',1I2,1A2,',',1I2,1A2,'):') + 302 FORMAT(' T_[',1I2,',',1I4,'] = ',1P,D19.12) + 303 FORMAT(' Number of integrals is ',1I4) 304 FORMAT(' R^[(',1I2,')] (',1I2,1A2,',',1I2,1A2,';',1I2,1A2,',',1I2,1A2,& - '):') - 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) - - RETURN - END SUBROUTINE SORT + '):') + 305 FORMAT(' V^[(',1I2,')]_[',1I8,',',1I8,'] = ',1P,D19.12) + + RETURN + END SUBROUTINE SORT diff --git a/src/appl/rangular90_mpi/sort_I.f90 b/src/appl/rangular90_mpi/sort_I.f90 index a0cb4298d..c8e2126bc 100644 --- a/src/appl/rangular90_mpi/sort_I.f90 +++ b/src/appl/rangular90_mpi/sort_I.f90 @@ -1,15 +1,15 @@ - MODULE sort_I + MODULE sort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:24:58 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE sort (NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NCOEFF - INTEGER, INTENT(OUT) :: NTGRAL - LOGICAL, INTENT(IN) :: LPRINT - INTEGER, INTENT(IN) :: NB - CHARACTER (LEN = *), INTENT(IN) :: FHEAD - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE sort (NFILE, NCOEFF, NTGRAL, LPRINT, NB, FHEAD) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NCOEFF + INTEGER, INTENT(OUT) :: NTGRAL + LOGICAL, INTENT(IN) :: LPRINT + INTEGER, INTENT(IN) :: NB + CHARACTER (LEN = *), INTENT(IN) :: FHEAD + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rangular90_mpi/strsum.f90 b/src/appl/rangular90_mpi/strsum.f90 index f3b5fff7f..0b9c45ba0 100644 --- a/src/appl/rangular90_mpi/strsum.f90 +++ b/src/appl/rangular90_mpi/strsum.f90 @@ -1,13 +1,13 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- Use hblock_C USE def_C @@ -17,49 +17,49 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE calen_I - USE convrt_I + USE calen_I + USE convrt_I !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, I - Character :: CTIME*10, CDATE*8 - CHARACTER :: RECORD*256, CDATA*26 + INTEGER :: LENTH, I + Character :: CTIME*10, CDATE*8 + CHARACTER :: RECORD*256, CDATA*26 !----------------------------------------------- ! ! ! Get the date and time of day; make this information the ! header of the summary file ! - CALL CALEN (CTIME, CDATE) - WRITE (24, *) 'GENMCP run at ', CTIME, ' on ', CDATE, '.' + CALL CALEN (CTIME, CDATE) + WRITE (24, *) 'GENMCP run at ', CTIME, ' on ', CDATE, '.' ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (DIAG) THEN - WRITE (24, *) - WRITE (24, *) 'Only diagonal matrix elements are computed.' - ELSE - IF (LFORDR) THEN - DO I = 1, NBLOCK - WRITE (24, *) - CALL CONVRT (ICCUT(I), RECORD, LENTH) + IF (DIAG) THEN + WRITE (24, *) + WRITE (24, *) 'Only diagonal matrix elements are computed.' + ELSE + IF (LFORDR) THEN + DO I = 1, NBLOCK + WRITE (24, *) + CALL CONVRT (ICCUT(I), RECORD, LENTH) WRITE (24, *) 'CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space.' - END DO - ENDIF - ENDIF + ' the zero-order space.' + END DO + ENDIF + ENDIF ! - RETURN - END SUBROUTINE STRSUM + RETURN + END SUBROUTINE STRSUM diff --git a/src/appl/rangular90_mpi/strsum_I.f90 b/src/appl/rangular90_mpi/strsum_I.f90 index d2cba577b..afcf67e39 100644 --- a/src/appl/rangular90_mpi/strsum_I.f90 +++ b/src/appl/rangular90_mpi/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/Makefile b/src/appl/rbiotransform90/Makefile old mode 100755 new mode 100644 index a1e1cecec..ee9bd295a --- a/src/appl/rbiotransform90/Makefile +++ b/src/appl/rbiotransform90/Makefile @@ -32,7 +32,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -o $@ @@ -42,5 +42,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - - diff --git a/src/appl/rbiotransform90/angdata.f90 b/src/appl/rbiotransform90/angdata.f90 index b52510d0c..c9d02f346 100644 --- a/src/appl/rbiotransform90/angdata.f90 +++ b/src/appl/rbiotransform90/angdata.f90 @@ -1,56 +1,56 @@ !*********************************************************************** ! * - SUBROUTINE ANGDATA(NAME, AVAIL, KAMAX) + SUBROUTINE ANGDATA(NAME, AVAIL, KAMAX) ! * ! Checks if the angular file name.T is available and appropriate * ! * ! Written by Per Jonsson 6 March 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE orb_C, ONLY: NCF, NW IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: KAMAX - LOGICAL, INTENT(OUT) :: AVAIL - CHARACTER, INTENT(INOUT) :: NAME*24 + INTEGER, INTENT(IN) :: KAMAX + LOGICAL, INTENT(OUT) :: AVAIL + CHARACTER, INTENT(INOUT) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, NF, NCFD, NWD, KAMAXD - LOGICAL :: FOUND + INTEGER :: J, NF, NCFD, NWD, KAMAXD + LOGICAL :: FOUND !----------------------------------------------- ! - J = INDEX(NAME,' ') - INQUIRE(FILE=NAME(1:J-1)//'.TB', EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (6, *) ' Angular file not available' - AVAIL = .FALSE. - RETURN - ELSE + J = INDEX(NAME,' ') + INQUIRE(FILE=NAME(1:J-1)//'.TB', EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (6, *) ' Angular file not available' + AVAIL = .FALSE. + RETURN + ELSE ! ! Open the file and check if it is appropriate for the present case ! - NF = 200 + NF = 200 OPEN(UNIT=NF, FILE=NAME(1:J-1)//'.TB', STATUS='OLD', FORM=& - 'UNFORMATTED', POSITION='asis') - REWIND (NF) - READ (NF) NCFD, NWD, KAMAXD - IF (.NOT.(NCFD==NCF .AND. NWD==NW .AND. KAMAXD==KAMAX)) THEN - WRITE (6, *) ' Angular file not appropriate' - AVAIL = .FALSE. - RETURN - ELSE - WRITE (6, *) ' Angular data read from file' - AVAIL = .TRUE. - ENDIF - ENDIF - RETURN - END SUBROUTINE ANGDATA + 'UNFORMATTED', POSITION='asis') + REWIND (NF) + READ (NF) NCFD, NWD, KAMAXD + IF (.NOT.(NCFD==NCF .AND. NWD==NW .AND. KAMAXD==KAMAX)) THEN + WRITE (6, *) ' Angular file not appropriate' + AVAIL = .FALSE. + RETURN + ELSE + WRITE (6, *) ' Angular data read from file' + AVAIL = .TRUE. + ENDIF + ENDIF + RETURN + END SUBROUTINE ANGDATA diff --git a/src/appl/rbiotransform90/angdata_I.f90 b/src/appl/rbiotransform90/angdata_I.f90 index f9eb31e42..324cb5ac9 100644 --- a/src/appl/rbiotransform90/angdata_I.f90 +++ b/src/appl/rbiotransform90/angdata_I.f90 @@ -1,12 +1,12 @@ - MODULE angdata_I + MODULE angdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE angdata (NAME, AVAIL, KAMAX) - CHARACTER (LEN = 24), INTENT(INOUT) :: NAME - LOGICAL, INTENT(OUT) :: AVAIL - INTEGER, INTENT(IN) :: KAMAX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE angdata (NAME, AVAIL, KAMAX) + CHARACTER (LEN = 24), INTENT(INOUT) :: NAME + LOGICAL, INTENT(OUT) :: AVAIL + INTEGER, INTENT(IN) :: KAMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/biotr.f90 b/src/appl/rbiotransform90/biotr.f90 index e8acea5da..569d47340 100644 --- a/src/appl/rbiotransform90/biotr.f90 +++ b/src/appl/rbiotransform90/biotr.f90 @@ -11,7 +11,7 @@ ! J. Olsen, M.R. Godefroid, P. Jonsson, P.A. Malmqvist and * ! C. Froese Fischer, Phys. Rev. E, 4499 (1995) * ! * - PROGRAM BIOTR + PROGRAM BIOTR ! * ! Program written by * ! * @@ -24,13 +24,13 @@ PROGRAM BIOTR ! and for reducing usage of CPU memory. NIST, October 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:17:22 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:17:22 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE default_C, ONLY: ndef, ndump USE sbdat_C, ONLY: NLMAX, KAMAX, NSHLII, NSHLFF @@ -40,51 +40,51 @@ PROGRAM BIOTR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setmc_I - USE setcon_I - USE setiso_I - USE radpar_I - USE radgrd_I - USE setqic_I - USE fname_I - USE setcslb_I - USE tcsl_I - USE kapdata_I - USE lodrwfi_I - USE lodrwff_I - USE brkt_I - USE gets_I - USE biotr1_I - USE radfile_I - USE genmcp_I + USE getyn_I + USE setmc_I + USE setcon_I + USE setiso_I + USE radpar_I + USE radgrd_I + USE setqic_I + USE fname_I + USE setcslb_I + USE tcsl_I + USE kapdata_I + USE lodrwfi_I + USE lodrwff_I + USE brkt_I + USE gets_I + USE biotr1_I + USE radfile_I + USE genmcp_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- -!GG INTEGER, PARAMETER :: LWORK1 = 100000 +!GG INTEGER, PARAMETER :: LWORK1 = 100000 INTEGER, PARAMETER :: LWORK1 = 10000000 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NLMAX) :: NINSHLI, NINSHLF - INTEGER :: NTESTG, NTESTL, NTEST, INPCI, NCORE1, NCORE2, MXL, K + INTEGER, DIMENSION(NLMAX) :: NINSHLI, NINSHLF + INTEGER :: NTESTG, NTESTL, NTEST, INPCI, NCORE1, NCORE2, MXL, K INTEGER :: NCOUNT1 - REAL(DOUBLE), DIMENSION(LWORK1) :: WORK - REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CISHL - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: S - REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CFSHL - LOGICAL :: YES - CHARACTER, DIMENSION(2) :: NAME*24 + REAL(DOUBLE), DIMENSION(LWORK1) :: WORK + REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CISHL + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: S + REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CFSHL + LOGICAL :: YES + CHARACTER, DIMENSION(2) :: NAME*24 CHARACTER(LEN=128) :: ISOFILE !----------------------------------------------- ! ISOFILE = 'isodata' ! Debug flags ! - NTESTG = 0 - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) + NTESTG = 0 + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) ! CALL STARTTIME (ncount1, 'BIOTRANSFORM') write(*,*) @@ -100,138 +100,138 @@ PROGRAM BIOTR write(*,*) ' name1.TB, name2.TB (angular files)' write(*,*) - WRITE (6, *) 'Default settings?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDEF = 0 - NDUMP = 1 - ELSE - NDEF = 1 - WRITE (6, *) 'Dump angular data on file?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDUMP = 1 - ELSE - NDUMP = 0 - ENDIF - ENDIF - WRITE (6, *) 'Input from a CI calculation?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - INPCI = 0 - ELSE - INPCI = 1 - ENDIF + WRITE (6, *) 'Default settings?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDEF = 0 + NDUMP = 1 + ELSE + NDEF = 1 + WRITE (6, *) 'Dump angular data on file?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDUMP = 1 + ELSE + NDUMP = 0 + ENDIF + ENDIF + WRITE (6, *) 'Input from a CI calculation?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + INPCI = 0 + ELSE + INPCI = 1 + ENDIF ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Open, check, load data from, and close the .iso file ! - CALL SETISO (ISOFILE) + CALL SETISO (ISOFILE) ! ! Determine the parameters controlling the radial grid ! - CALL RADPAR + CALL RADPAR ! ! Generate the radial grid ! - CALL RADGRD + CALL RADGRD ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Obtain the names of the initial and final state files ! and open files where the transformed orbitals and CI ! coefficients are to be dumped ! - CALL FNAME (NAME) + CALL FNAME (NAME) ! ! Open, check, load data from and close the initial state CSL file. ! - CALL SETCSLB (NAME(1), NCORE1,1) + CALL SETCSLB (NAME(1), NCORE1,1) ! ! Transfer the data to the initial state COMMON ! - CALL TCSL (1) + CALL TCSL (1) ! ! Open, check, load data from and close the final state CSL file. ! - CALL SETCSLB (NAME(2), NCORE2,2) + CALL SETCSLB (NAME(2), NCORE2,2) ! ! Transfer the data to the final state COMMON ! - CALL TCSL (2) + CALL TCSL (2) ! ! Determine the number of kappa quantum numbers and ! the number of orbitals for each kappa quantum number ! for the initial state and final states ! - CALL KAPDATA (NTESTG, NCORE1, NCORE2) + CALL KAPDATA (NTESTG, NCORE1, NCORE2) ! ! Read the the radial orbitals for the initial state ! - CALL LODRWFI (NAME(1), NTESTG) + CALL LODRWFI (NAME(1), NTESTG) ! ! Read the the radial orbitals for the initial state ! - CALL LODRWFF (NAME(2), NTESTG) + CALL LODRWFF (NAME(2), NTESTG) ! ! Calculate the radial overlap matrices ! - WRITE (*, *) - WRITE (*, *) ' ******************************************' - WRITE (*, *) ' Overlap matrix before orbital rotations' - WRITE (*, *) ' *****************************************' - WRITE (*, *) - - CALL BRKT - - CALL GETS (S, NWII, NWFF) - + WRITE (*, *) + WRITE (*, *) ' ******************************************' + WRITE (*, *) ' Overlap matrix before orbital rotations' + WRITE (*, *) ' *****************************************' + WRITE (*, *) + + CALL BRKT + + CALL GETS (S, NWII, NWFF) + ! ! Once we have the overlap matrices ! we can manipulate the initial and final state separately. ! - MXL = KAMAX + MXL = KAMAX ! !. Calculate biorthonormal orbitals, and orbital matrix !. for counter transformation of CI coefficients. ! CALL BIOTR1 (PFII, QFII, NSHLII, NINSHLI, PFFF, QFFF, & NSHLFF, NINSHLF, NNNP, KAMAX, WORK, LWORK1, NTESTG, & - CISHL, CICI, CFSHL, CFCI) - WRITE (*, *) - WRITE (*, *) ' ****************************************' - WRITE (*, *) ' Overlap matrix after orbital rotations' - WRITE (*, *) ' ****************************************' - WRITE (*, *) - - CALL BRKT + CISHL, CICI, CFSHL, CFCI) + WRITE (*, *) + WRITE (*, *) ' ****************************************' + WRITE (*, *) ' Overlap matrix after orbital rotations' + WRITE (*, *) ' ****************************************' + WRITE (*, *) + + CALL BRKT ! ! Write the transformed radial functions to file ! - CALL RADFILE (NAME) + CALL RADFILE (NAME) ! ! Obtain one-electron coupling coefficients for the initial state. ! The coefficients are dumped on files one kappa in turn and ! thus the different kappa can be manipulated independently. ! The interface with the transformation part is in the routine mcp ! - CALL GENMCP (NAME(1), 1, NTESTG, INPCI) + CALL GENMCP (NAME(1), 1, NTESTG, INPCI) !***** added by Yu Zou, Feb.18,2000 *********** - DO K = 1, KAMAX - CLOSE(UNIT=80 + K, STATUS='DELETE') - END DO + DO K = 1, KAMAX + CLOSE(UNIT=80 + K, STATUS='DELETE') + END DO !***** added by Yu Zou, Feb.18,2000 *********** ! ! Obtain one-electron coupling coefficients for the final state. @@ -239,12 +239,12 @@ PROGRAM BIOTR ! thus the different kappa can be manipulated independently. ! The interface with the transformation part is in the routine mcp ! - CALL GENMCP (NAME(2), 2, NTESTG, INPCI) - - DO K = 1, KAMAX - CLOSE(UNIT=80 + K, STATUS='DELETE') - END DO + CALL GENMCP (NAME(2), 2, NTESTG, INPCI) + + DO K = 1, KAMAX + CLOSE(UNIT=80 + K, STATUS='DELETE') + END DO CALL STOPTIME (ncount1, 'BIOTRANSFORM') - - STOP - END PROGRAM BIOTR + + STOP + END PROGRAM BIOTR diff --git a/src/appl/rbiotransform90/biotr1.f90 b/src/appl/rbiotransform90/biotr1.f90 index f5670b050..06f8c7559 100644 --- a/src/appl/rbiotransform90/biotr1.f90 +++ b/src/appl/rbiotransform90/biotr1.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & - NGRID, MXL, SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) + NGRID, MXL, SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) ! * ! Generate Matrices for rotating radial functions and * ! for counter rotating CI coefficients * @@ -58,34 +58,34 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & ! occupied shells ( inactive+active) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ifnmnx_I - USE ielsum_I -! USE gets_I -! USE wrtmat_I -! USE copvec_I -! USE invmat_I -! USE ulla_I -! USE trpmat_I -! USE matml4_I -! USE scalve_I -! USE setvec_I -! USE pamtmt_I + USE ifnmnx_I + USE ielsum_I +! USE gets_I +! USE wrtmat_I +! USE copvec_I +! USE invmat_I +! USE ulla_I +! USE trpmat_I +! USE matml4_I +! USE scalve_I +! USE setvec_I +! USE pamtmt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER, INTENT(IN) :: NGRID, MXL - INTEGER, INTENT(IN) :: LSCR, NTESTG + INTEGER, INTENT(IN) :: LSCR, NTESTG INTEGER, DIMENSION(MXL) :: NLI, NINSHLI, NLF, NINSHLF ! The following have dimensions (NGRID:*) !GG REAL(DOUBLE), DIMENSION(:,:), pointer :: PI, QI, PF, QF @@ -104,125 +104,125 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & NLTF, KFREE, KLPI, KLPF, KLPIF, KLSTOT, KLSIF, KLSIFI, & KLCI, KLCF, KLSCR, L, IIOFF, IFOFF, NI, NF, NIFMN, III,& JJJ, KLPMX, KLPMN, NMX, NMN, KLCMX, KLCMN, NDIFF, J, & - KLTI, I, KLTF - REAL(DOUBLE) :: TII, TIII + KLTI, I, KLTF + REAL(DOUBLE) :: TII, TIII !----------------------------------------------- ! - NTESTL = 0 - NTEST = MAX(NTESTL,NTESTG) - IF (NTEST >= 1) THEN - WRITE (6, *) - WRITE (6, *) ' *************************' - WRITE (6, *) ' * Entering BIOTR1 *' - WRITE (6, *) ' *************************' - WRITE (6, *) - ENDIF + NTESTL = 0 + NTEST = MAX(NTESTL,NTESTG) + IF (NTEST >= 1) THEN + WRITE (6, *) + WRITE (6, *) ' *************************' + WRITE (6, *) ' * Entering BIOTR1 *' + WRITE (6, *) ' *************************' + WRITE (6, *) + ENDIF ! !. Scratch should at least be of length ! - ILI = 1 - ILF = 1 + ILI = 1 + ILF = 1 ! !. Largest number of shells of a given symmetry ! - NLIMX = IFNMNX(NLI,MXL,1) - NLFMX = IFNMNX(NLF,MXL,1) - NLIFMX = MAX(NLIMX,NLFMX) + NLIMX = IFNMNX(NLI,MXL,1) + NLFMX = IFNMNX(NLF,MXL,1) + NLIFMX = MAX(NLIMX,NLFMX) IF (NTEST >= 10) WRITE (6, *) ' NLIMX,NLFMX NLIFMX ', NLIMX, NLFMX, & - NLIFMX + NLIFMX ! !. Total numner of shells ! - NLTI = IELSUM(NLI,MXL) - NLTF = IELSUM(NLF,MXL) - IF (NTEST >= 10) WRITE (6, *) ' NLTI NLTF', NLTI, NLTF + NLTI = IELSUM(NLI,MXL) + NLTF = IELSUM(NLF,MXL) + IF (NTEST >= 10) WRITE (6, *) ' NLTI NLTF', NLTI, NLTF ! ! Scratch space for orbital rotations - KFREE = 1 + KFREE = 1 ! - KLPI = KFREE - KFREE = KFREE + NLIMX*NGRID - WRITE (6, *) ' In biotrn: KLPI = ', KLPI - WRITE (6, *) ' KFREE = ', KFREE + KLPI = KFREE + KFREE = KFREE + NLIMX*NGRID + WRITE (6, *) ' In biotrn: KLPI = ', KLPI + WRITE (6, *) ' KFREE = ', KFREE ! - KLPF = KFREE - KFREE = KFREE + NLFMX*NGRID - WRITE (6, *) ' In biotrn: KLPF = ', KLPF - WRITE (6, *) ' KFREE = ', KFREE + KLPF = KFREE + KFREE = KFREE + NLFMX*NGRID + WRITE (6, *) ' In biotrn: KLPF = ', KLPF + WRITE (6, *) ' KFREE = ', KFREE ! - KLPIF = KFREE - KFREE = KFREE + NLIFMX*NGRID - WRITE (6, *) ' In biotrn: KLPIF = ', KLPIF - WRITE (6, *) ' KFREE = ', KFREE + KLPIF = KFREE + KFREE = KFREE + NLIFMX*NGRID + WRITE (6, *) ' In biotrn: KLPIF = ', KLPIF + WRITE (6, *) ' KFREE = ', KFREE ! !. Total overlap matrix ! - KLSTOT = KFREE - KFREE = KFREE + NLTI*NLTF - WRITE (6, *) ' In biotrn: KLSTOT = ', KLSTOT - WRITE (6, *) ' KFREE = ', KFREE -! - KLSIF = KFREE - KFREE = KFREE + NLIFMX**2 - WRITE (6, *) ' In biotrn: KLSIF = ', KLSIF - WRITE (6, *) ' KFREE = ', KFREE -! - KLSIFI = KFREE - KFREE = KFREE + NLIFMX**2 - WRITE (6, *) ' In biotrn: KLSIFI = ', KLSIFI - WRITE (6, *) ' KFREE = ', KFREE -! - KLCI = KFREE - KFREE = KFREE + NLIFMX**2 - WRITE (6, *) ' In biotrn: KLCI = ', KLCI - WRITE (6, *) ' KFREE = ', KFREE -! - KLCF = KFREE - KFREE = KFREE + NLIFMX**2 - WRITE (6, *) ' In biotrn: KLCF = ', KLCF - WRITE (6, *) ' KFREE = ', KFREE -! - KLSCR = KFREE - KFREE = KFREE + NLIFMX**2 + NLIFMX*(NLIFMX + 1) - WRITE (6, *) ' In biotrn: KLSCR = ', KLSCR - WRITE (6, *) ' KFREE = ', KFREE - WRITE (6, *) ' => FREE = ', KFREE + KLSTOT = KFREE + KFREE = KFREE + NLTI*NLTF + WRITE (6, *) ' In biotrn: KLSTOT = ', KLSTOT + WRITE (6, *) ' KFREE = ', KFREE +! + KLSIF = KFREE + KFREE = KFREE + NLIFMX**2 + WRITE (6, *) ' In biotrn: KLSIF = ', KLSIF + WRITE (6, *) ' KFREE = ', KFREE +! + KLSIFI = KFREE + KFREE = KFREE + NLIFMX**2 + WRITE (6, *) ' In biotrn: KLSIFI = ', KLSIFI + WRITE (6, *) ' KFREE = ', KFREE +! + KLCI = KFREE + KFREE = KFREE + NLIFMX**2 + WRITE (6, *) ' In biotrn: KLCI = ', KLCI + WRITE (6, *) ' KFREE = ', KFREE +! + KLCF = KFREE + KFREE = KFREE + NLIFMX**2 + WRITE (6, *) ' In biotrn: KLCF = ', KLCF + WRITE (6, *) ' KFREE = ', KFREE +! + KLSCR = KFREE + KFREE = KFREE + NLIFMX**2 + NLIFMX*(NLIFMX + 1) + WRITE (6, *) ' In biotrn: KLSCR = ', KLSCR + WRITE (6, *) ' KFREE = ', KFREE + WRITE (6, *) ' => FREE = ', KFREE ! !. Check length of scratch ! - IF (LSCR <= KFREE - 1) THEN - WRITE (6,*)' BIOTR1 in trouble ! ' + IF (LSCR <= KFREE - 1) THEN + WRITE (6,*)' BIOTR1 in trouble ! ' WRITE (6,*)' Increase dimension of scratch before call to BIOTR1' WRITE (6,*)' Current and required length (LSCR,KFREE-1)', LSCR, & - KFREE - 1 - STOP 'Increase LWORK before call to BIOTR1' - ENDIF + KFREE - 1 + STOP 'Increase LWORK before call to BIOTR1' + ENDIF ! !. Obtain overlap matrix ! - CALL GETS (SCR(KLSTOT), NLTI,NLTF) - - DO L = 1, MXL - IF (NTEST >= 5) THEN - WRITE (6, *) ' L = ', L - WRITE (6, *) ' Orbital rotation...' - ENDIF + CALL GETS (SCR(KLSTOT), NLTI,NLTF) + + DO L = 1, MXL + IF (NTEST >= 5) THEN + WRITE (6, *) ' L = ', L + WRITE (6, *) ' Orbital rotation...' + ENDIF ! !. Offsets for given L in shell matrices ! - IF (L == 1) THEN - IIOFF = 1 - IFOFF = 1 - ELSE - IIOFF = IIOFF + NLI(L-1)**2 - IFOFF = IFOFF + NLF(L-1)**2 - ENDIF - IF (NTEST >= 1) THEN - WRITE (6, *) + IF (L == 1) THEN + IIOFF = 1 + IFOFF = 1 + ELSE + IIOFF = IIOFF + NLI(L-1)**2 + IFOFF = IFOFF + NLF(L-1)**2 + ENDIF + IF (NTEST >= 1) THEN + WRITE (6, *) WRITE (6, *) & ' BIOTRN : Information on transformations of shells with L =',L - WRITE (6, *) - ENDIF + WRITE (6, *) + ENDIF ! ! ========================================================= ! 1 : Obtain Biorthogonal forms of initial and final shells @@ -253,220 +253,220 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & ! ! With Y = -S-1*X ! - NI = NLI(L) - NF = NLF(L) + NI = NLI(L) + NF = NLF(L) ! !.1.1 : Obtain shells of given L in proper order for ! biorthogonal treatment ! - IF (L == 1) THEN - ILI = 1 - ILF = 1 - ELSE - ILI = ILI + NLI(L-1) - ILF = ILF + NLF(L-1) - ENDIF - + IF (L == 1) THEN + ILI = 1 + ILF = 1 + ELSE + ILI = ILI + NLI(L-1) + ILF = ILF + NLF(L-1) + ENDIF + ! ! 1.2 obtain biorthogonal of the first min(ni,nf) shells ! - NIFMN = MIN(NI,NF) + NIFMN = MIN(NI,NF) ! !. Overlap matrix SIF = Integral (PI(I)*PF(J)) ! !ww Per change to support cases like 3s2p1d 3s2p. The belonging endif !ww Is just at the end - - IF (NIFMN <= 0) CYCLE - - DO III = 1, NIFMN - DO JJJ = 1, NIFMN + + IF (NIFMN <= 0) CYCLE + + DO III = 1, NIFMN + DO JJJ = 1, NIFMN SCR(KLSIF+(JJJ-1)*NIFMN+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-1)*NLTI& - +III+ILI-1) - END DO - END DO - IF (NTEST >= 15) THEN - WRITE (6, *) ' Overlap matrix ' - CALL WRTMAT (SCR(KLSIF), NIFMN, NIFMN, NIFMN, NIFMN) - ENDIF + +III+ILI-1) + END DO + END DO + IF (NTEST >= 15) THEN + WRITE (6, *) ' Overlap matrix ' + CALL WRTMAT (SCR(KLSIF), NIFMN, NIFMN, NIFMN, NIFMN) + ENDIF ! ! Obtain upper triangular CI and CF so CI(T) S CF = 1 ! or CF CI(T) = S-1, which corresponds to an UL decomposition ! !. Invert S ! - CALL COPVEC (SCR(KLSIF), SCR(KLSIFI), NIFMN**2) - CALL INVMAT (SCR(KLSIFI), SCR(KLCI), NIFMN, NIFMN) - + CALL COPVEC (SCR(KLSIF), SCR(KLSIFI), NIFMN**2) + CALL INVMAT (SCR(KLSIFI), SCR(KLCI), NIFMN, NIFMN) + !. UL decompose - CALL COPVEC (SCR(KLSIFI), SCR(KLSIF), NIFMN**2) + CALL COPVEC (SCR(KLSIFI), SCR(KLSIF), NIFMN**2) CALL ULLA (SCR(KLSIF), SCR(KLCF), SCR(KLCI), NIFMN, SCR(KLSCR)) - CALL TRPMAT (SCR(KLCI), NIFMN, NIFMN, SCR(KLSCR)) - CALL COPVEC (SCR(KLSCR), SCR(KLCI), NIFMN**2) + CALL TRPMAT (SCR(KLCI), NIFMN, NIFMN, SCR(KLSCR)) + CALL COPVEC (SCR(KLSCR), SCR(KLCI), NIFMN**2) ! !. The transformation matrix between the first NIFMX !. shells is now known, biorthogonalize remaining orbitals ! - IF (NI/=NF .AND. NI/=0 .AND. NF/=0) THEN - IF (NI > NF) THEN - KLPMX = KLPI - KLPMN = KLPF - NMX = NI - NMN = NF - KLCMX = KLCI - KLCMN = KLCF - ELSE - KLPMX = KLPF - KLPMN = KLPI - NMX = NF - NMN = NI - KLCMX = KLCF - KLCMN = KLCI - ENDIF - NDIFF = NMX - NMN + IF (NI/=NF .AND. NI/=0 .AND. NF/=0) THEN + IF (NI > NF) THEN + KLPMX = KLPI + KLPMN = KLPF + NMX = NI + NMN = NF + KLCMX = KLCI + KLCMN = KLCF + ELSE + KLPMX = KLPF + KLPMN = KLPI + NMX = NF + NMN = NI + KLCMX = KLCF + KLCMN = KLCI + ENDIF + NDIFF = NMX - NMN ! ! Y = -S-1 * X !. overlap X between remaining orbitals and the other set ! - IF (NI > NF) THEN + IF (NI > NF) THEN ! ! I columns F rows ! - DO III = NMN + 1, NMX - DO JJJ = 1, NF + DO III = NMN + 1, NMX + DO JJJ = 1, NF SCR(KLSIF+(III-NMN-1)*NF+JJJ-1) = SCR(KLSTOT-1+(JJJ+ILF-1-& - 1)*NLTI+III+ILI-1) - END DO - END DO - ELSE IF (NF > NI) THEN + 1)*NLTI+III+ILI-1) + END DO + END DO + ELSE IF (NF > NI) THEN ! F columns I rows - DO JJJ = NMN + 1, NMX - DO III = 1, NI + DO JJJ = NMN + 1, NMX + DO III = 1, NI SCR(KLSIF+(JJJ-NMN-1)*NI+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-& - 1)*NLTI+III+ILI-1) - END DO - END DO - ENDIF -! - IF (NI > NF) THEN - CALL TRPMAT (SCR(KLSIFI), NMN, NMN, SCR(KLSCR)) - CALL COPVEC (SCR(KLSCR), SCR(KLSIFI), NMN**2) - ENDIF + 1)*NLTI+III+ILI-1) + END DO + END DO + ENDIF +! + IF (NI > NF) THEN + CALL TRPMAT (SCR(KLSIFI), NMN, NMN, SCR(KLSCR)) + CALL COPVEC (SCR(KLSCR), SCR(KLSIFI), NMN**2) + ENDIF CALL MATML4 (SCR(KLSCR), SCR(KLSIFI), SCR(KLSIF), NMN, NDIFF, NMN, & - NMN, NMN, NDIFF, 0) - CALL SCALVE (SCR(KLSCR), -1.0D0, NMN*NDIFF) - CALL COPVEC (SCR(KLSCR), SCR(KLSIF), NMN*NDIFF) + NMN, NMN, NDIFF, 0) + CALL SCALVE (SCR(KLSCR), -1.0D0, NMN*NDIFF) + CALL COPVEC (SCR(KLSCR), SCR(KLSIF), NMN*NDIFF) ! ! Construct complete CMX ! - CALL SETVEC (SCR(KLSCR), 0.0D0, NMX**2) - DO J = 1, NMX - IF (J <= NIFMN) THEN + CALL SETVEC (SCR(KLSCR), 0.0D0, NMX**2) + DO J = 1, NMX + IF (J <= NIFMN) THEN CALL COPVEC (SCR(KLCMX+(J-1)*NIFMN), SCR(KLSCR+(J-1)*NMX), & - NMN) - ELSE + NMN) + ELSE CALL COPVEC (SCR(KLSIF+(J-NMN-1)*NMN), SCR(KLSCR+(J-1)*NMX), & - NMN) - SCR(KLSCR-1+(J-1)*NMX+J) = 1.0D0 - ENDIF - END DO + NMN) + SCR(KLSCR-1+(J-1)*NMX+J) = 1.0D0 + ENDIF + END DO ! - CALL COPVEC (SCR(KLSCR), SCR(KLCMX), NMX**2) - ENDIF + CALL COPVEC (SCR(KLSCR), SCR(KLCMX), NMX**2) + ENDIF !ww Pertest ! ENDIF ! !. The two upper triangular matrices CI and CF are now known !. Transfer to permanent arrays ! - CALL COPVEC (SCR(KLCI), CISHL(IIOFF), NI**2) - CALL COPVEC (SCR(KLCF), CFSHL(IFOFF), NF**2) + CALL COPVEC (SCR(KLCI), CISHL(IIOFF), NI**2) + CALL COPVEC (SCR(KLCF), CFSHL(IFOFF), NF**2) ! !. Rotate the large component of the shells ! - CALL COPVEC (PI(1,ILI), SCR(KLPI), NI*NGRID) - CALL COPVEC (PF(1,ILF), SCR(KLPF), NF*NGRID) + CALL COPVEC (PI(1,ILI), SCR(KLPI), NI*NGRID) + CALL COPVEC (PF(1,ILF), SCR(KLPF), NF*NGRID) ! - WRITE (*, *) 'Transformation matrices initial' - CALL WRTMAT (SCR(KLCI), NI, NI, NI, NI) + WRITE (*, *) 'Transformation matrices initial' + CALL WRTMAT (SCR(KLCI), NI, NI, NI, NI) CALL MATML4 (SCR(KLPIF), SCR(KLPI), SCR(KLCI), NGRID, NI, NGRID, NI, & - NI, NI, 0) - CALL COPVEC (SCR(KLPIF), PI(1,ILI), NI*NGRID) - WRITE (*, *) 'Transformation matrices final' - CALL WRTMAT (SCR(KLCF), NF, NF, NF, NF) + NI, NI, 0) + CALL COPVEC (SCR(KLPIF), PI(1,ILI), NI*NGRID) + WRITE (*, *) 'Transformation matrices final' + CALL WRTMAT (SCR(KLCF), NF, NF, NF, NF) CALL MATML4 (SCR(KLPIF), SCR(KLPF), SCR(KLCF), NGRID, NF, NGRID, NF, & - NF, NF, 0) - CALL COPVEC (SCR(KLPIF), PF(1,ILF), NF*NGRID) + NF, NF, 0) + CALL COPVEC (SCR(KLPIF), PF(1,ILF), NF*NGRID) ! !. Rotate the small component of the shells ! - CALL COPVEC (QI(1,ILI), SCR(KLPI), NI*NGRID) - CALL COPVEC (QF(1,ILF), SCR(KLPF), NF*NGRID) + CALL COPVEC (QI(1,ILI), SCR(KLPI), NI*NGRID) + CALL COPVEC (QF(1,ILF), SCR(KLPF), NF*NGRID) ! CALL MATML4 (SCR(KLPIF), SCR(KLPI), SCR(KLCI), NGRID, NI, NGRID, NI, & - NI, NI, 0) - CALL COPVEC (SCR(KLPIF), QI(1,ILI), NI*NGRID) + NI, NI, 0) + CALL COPVEC (SCR(KLPIF), QI(1,ILI), NI*NGRID) CALL MATML4 (SCR(KLPIF), SCR(KLPF), SCR(KLCF), NGRID, NF, NGRID, NF, & - NF, NF, 0) - CALL COPVEC (SCR(KLPIF), QF(1,ILF), NF*NGRID) + NF, NF, 0) + CALL COPVEC (SCR(KLPIF), QF(1,ILF), NF*NGRID) ! - IF (NTEST >= 1) THEN - WRITE (6, *) ' Test of overlap of biorthonormal functions' + IF (NTEST >= 1) THEN + WRITE (6, *) ' Test of overlap of biorthonormal functions' ! F columns I rows - DO JJJ = 1, NF - DO III = 1, NI + DO JJJ = 1, NF + DO III = 1, NI SCR(KLSIF+(JJJ-1)*NI+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-1)*NLTI& - +III+ILI-1) - END DO - END DO + +III+ILI-1) + END DO + END DO CALL MATML4 (SCR(KLSCR), SCR(KLCI), SCR(KLSIF), NI, NF, NI, NI, NI& - , NF, 1) + , NF, 1) CALL MATML4 (SCR(KLSIF), SCR(KLSCR), SCR(KLCF), NI, NF, NI, NF, NF& - , NF, 0) + , NF, 0) WRITE (6, *) & - ' new overlap matrix ( should be 1 on diag, 0 elsewhere )' - CALL WRTMAT (SCR(KLSIF), NI, NF, NI, NF) - ENDIF - - IF (NTEST >= 1) THEN - WRITE (6, *) - WRITE (6, *) ' Orbital Rotation matrix for I state' - CALL WRTMAT (CISHL(IIOFF), NI, NI, NI, NI) - WRITE (6, *) ' Orbital Rotation matrix for F state' - CALL WRTMAT (CFSHL(IFOFF), NF, NF, NF, NF) - WRITE (6, *) - ENDIF + ' new overlap matrix ( should be 1 on diag, 0 elsewhere )' + CALL WRTMAT (SCR(KLSIF), NI, NF, NI, NF) + ENDIF + + IF (NTEST >= 1) THEN + WRITE (6, *) + WRITE (6, *) ' Orbital Rotation matrix for I state' + CALL WRTMAT (CISHL(IIOFF), NI, NI, NI, NI) + WRITE (6, *) ' Orbital Rotation matrix for F state' + CALL WRTMAT (CFSHL(IFOFF), NF, NF, NF, NF) + WRITE (6, *) + ENDIF ! !. Matrix for counterrotation of CI coefficients, initial state ! - KLTI = KLSIF - CALL PAMTMT (SCR(KLCI), SCR(KLTI), SCR(KLSCR), NI) - DO I = 1, NI - TII = SCR(KLTI-1+(I-1)*NI+I) - TIII = 1.0D0/TII - CALL SCALVE (SCR(KLTI+(I-1)*NI), TIII, I - 1) - END DO - CALL COPVEC (SCR(KLTI), CICI(IIOFF), NI*NI) + KLTI = KLSIF + CALL PAMTMT (SCR(KLCI), SCR(KLTI), SCR(KLSCR), NI) + DO I = 1, NI + TII = SCR(KLTI-1+(I-1)*NI+I) + TIII = 1.0D0/TII + CALL SCALVE (SCR(KLTI+(I-1)*NI), TIII, I - 1) + END DO + CALL COPVEC (SCR(KLTI), CICI(IIOFF), NI*NI) ! !. Matrix for counterrotation of CI coefficients, Final state ! - KLTF = KLSIF - CALL PAMTMT (SCR(KLCF), SCR(KLTF), SCR(KLSCR), NF) - DO I = 1, NF - TII = SCR(KLTF-1+(I-1)*NF+I) - TIII = 1.0D0/TII - CALL SCALVE (SCR(KLTF+(I-1)*NF), TIII, I - 1) - END DO - CALL COPVEC (SCR(KLTF), CFCI(IFOFF), NF*NF) - IF (NTEST < 1) CYCLE - WRITE (6, *) - WRITE (6, *) ' CI-Rotation matrix for I state' - CALL WRTMAT (CICI(IIOFF), NI, NI, NI, NI) - WRITE (6, *) ' CI-Rotation matrix for F state' - CALL WRTMAT (CFCI(IFOFF), NF, NF, NF, NF) - WRITE (6, *) - - END DO -! - RETURN - END SUBROUTINE BIOTR1 + KLTF = KLSIF + CALL PAMTMT (SCR(KLCF), SCR(KLTF), SCR(KLSCR), NF) + DO I = 1, NF + TII = SCR(KLTF-1+(I-1)*NF+I) + TIII = 1.0D0/TII + CALL SCALVE (SCR(KLTF+(I-1)*NF), TIII, I - 1) + END DO + CALL COPVEC (SCR(KLTF), CFCI(IFOFF), NF*NF) + IF (NTEST < 1) CYCLE + WRITE (6, *) + WRITE (6, *) ' CI-Rotation matrix for I state' + CALL WRTMAT (CICI(IIOFF), NI, NI, NI, NI) + WRITE (6, *) ' CI-Rotation matrix for F state' + CALL WRTMAT (CFCI(IFOFF), NF, NF, NF, NF) + WRITE (6, *) + + END DO +! + RETURN + END SUBROUTINE BIOTR1 diff --git a/src/appl/rbiotransform90/biotr1_I.f90 b/src/appl/rbiotransform90/biotr1_I.f90 index 60a7f78ef..3743a06a2 100644 --- a/src/appl/rbiotransform90/biotr1_I.f90 +++ b/src/appl/rbiotransform90/biotr1_I.f90 @@ -1,28 +1,28 @@ - MODULE biotr1_I + MODULE biotr1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE biotr1 (PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, NGRID, MXL& - , SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NGRID,*) :: PI - REAL(DOUBLE), DIMENSION(NGRID,*) :: QI - INTEGER, DIMENSION(MXL), INTENT(IN) :: NLI - INTEGER, DIMENSION(MXL) :: NINSHLI - REAL(DOUBLE), DIMENSION(NGRID,*) :: PF - REAL(DOUBLE), DIMENSION(NGRID,*) :: QF - INTEGER, DIMENSION(MXL), INTENT(IN) :: NLF - INTEGER, DIMENSION(MXL) :: NINSHLF - INTEGER, INTENT(IN) :: NGRID - INTEGER, INTENT(IN) :: MXL - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR - INTEGER, INTENT(IN) :: LSCR - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), DIMENSION(*) :: CISHL - REAL(DOUBLE), DIMENSION(*) :: CICI - REAL(DOUBLE), DIMENSION(*) :: CFSHL - REAL(DOUBLE), DIMENSION(*) :: CFCI - END SUBROUTINE - END INTERFACE - END MODULE + , SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NGRID,*) :: PI + REAL(DOUBLE), DIMENSION(NGRID,*) :: QI + INTEGER, DIMENSION(MXL), INTENT(IN) :: NLI + INTEGER, DIMENSION(MXL) :: NINSHLI + REAL(DOUBLE), DIMENSION(NGRID,*) :: PF + REAL(DOUBLE), DIMENSION(NGRID,*) :: QF + INTEGER, DIMENSION(MXL), INTENT(IN) :: NLF + INTEGER, DIMENSION(MXL) :: NINSHLF + INTEGER, INTENT(IN) :: NGRID + INTEGER, INTENT(IN) :: MXL + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR + INTEGER, INTENT(IN) :: LSCR + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), DIMENSION(*) :: CISHL + REAL(DOUBLE), DIMENSION(*) :: CICI + REAL(DOUBLE), DIMENSION(*) :: CFSHL + REAL(DOUBLE), DIMENSION(*) :: CFCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/bndinv.f90 b/src/appl/rbiotransform90/bndinv.f90 index 18867c135..98c11b009 100644 --- a/src/appl/rbiotransform90/bndinv.f90 +++ b/src/appl/rbiotransform90/bndinv.f90 @@ -3,7 +3,7 @@ ! B N D I N V ! ------------------------------------------------------------------ ! - SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) + SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) ! ! DOUBLE PRECISION MATRIX INVERSION SUBROUTINE ! FROM "DLYTAP". @@ -11,151 +11,151 @@ SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) !* DOUBLE PRECISION E,F !* DOUBLE PRECISION A,EL,D,DSQRT,C,S,DETERP !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(OUT) :: ITEST - INTEGER , INTENT(IN) :: NSIZE - REAL(DOUBLE) , INTENT(OUT) :: DETERM - REAL(DOUBLE) , INTENT(IN) :: EPSIL - REAL(DOUBLE) , INTENT(INOUT) :: A(NSIZE,NSIZE) - REAL(DOUBLE) , INTENT(INOUT) :: EL(NSIZE,NSIZE) + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(OUT) :: ITEST + INTEGER , INTENT(IN) :: NSIZE + REAL(DOUBLE) , INTENT(OUT) :: DETERM + REAL(DOUBLE) , INTENT(IN) :: EPSIL + REAL(DOUBLE) , INTENT(INOUT) :: A(NSIZE,NSIZE) + REAL(DOUBLE) , INTENT(INOUT) :: EL(NSIZE,NSIZE) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISL2, K000FX, INDSNL, I, J, N1, M, K, J1, I1, KS - REAL(DOUBLE) :: D, C, S, DETERP, F, E, EPSILP, RAT + INTEGER :: ISL2, K000FX, INDSNL, I, J, N1, M, K, J1, I1, KS + REAL(DOUBLE) :: D, C, S, DETERP, F, E, EPSILP, RAT !----------------------------------------------- - IF (N < 2) GO TO 140 - ISL2 = 0 - K000FX = 2 - IF (ISL2 == 0) INDSNL = 2 - IF (ISL2 == 1) INDSNL = 1 + IF (N < 2) GO TO 140 + ISL2 = 0 + K000FX = 2 + IF (ISL2 == 0) INDSNL = 2 + IF (ISL2 == 1) INDSNL = 1 ! CALL SLITET(2,INDSNL) ! CALL OVERFL(K000FX) ! CALL DVCHK(K000FX) ! ! SET EL = IDENTITY MATRIX - DO I = 1, N - EL(I,:N) = 0.0D0 - EL(I,I) = 1.0D0 - END DO + DO I = 1, N + EL(I,:N) = 0.0D0 + EL(I,I) = 1.0D0 + END DO ! ! TRIANGULARIZE A, FORM EL ! - N1 = N - 1 - M = 2 - DO J = 1, N1 - DO I = M, N - IF (A(I,J) == 0.0D0) CYCLE - D = DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J)) - C = A(J,J)/D - S = A(I,J)/D - DO K = J, N - D = C*A(J,K) + S*A(I,K) - A(I,K) = C*A(I,K) - S*A(J,K) - A(J,K) = D - END DO - DO K = 1, N - D = C*EL(J,K) + S*EL(I,K) - EL(I,K) = C*EL(I,K) - S*EL(J,K) - EL(J,K) = D - END DO - END DO - M = M + 1 - END DO + N1 = N - 1 + M = 2 + DO J = 1, N1 + DO I = M, N + IF (A(I,J) == 0.0D0) CYCLE + D = DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J)) + C = A(J,J)/D + S = A(I,J)/D + DO K = J, N + D = C*A(J,K) + S*A(I,K) + A(I,K) = C*A(I,K) - S*A(J,K) + A(J,K) = D + END DO + DO K = 1, N + D = C*EL(J,K) + S*EL(I,K) + EL(I,K) = C*EL(I,K) - S*EL(J,K) + EL(J,K) = D + END DO + END DO + M = M + 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,51),K000FX ! ! CALCULATE THE DETERMINANT - DETERP = A(1,1) - DO I = 2, N - DETERP = DETERP*A(I,I) - END DO - DETERM = DETERP + DETERP = A(1,1) + DO I = 2, N + DETERP = DETERP*A(I,I) + END DO + DETERM = DETERP ! CALL OVERFL(K000FX) ! GO TO (140,520,520),K000FX ! ! IS MATRIX SINGULAR - F = A(1,1) - E = A(1,1) - DO I = 2, N - IF (DABS(F) < DABS(A(I,I))) F = A(I,I) - IF (DABS(E) <= DABS(A(I,I))) CYCLE - E = A(I,I) - END DO - EPSILP = EPSIL - IF (EPSILP <= 0) EPSILP = 1.0E-8 - RAT = E/F - IF (ABS(RAT) < EPSILP) GO TO 130 + F = A(1,1) + E = A(1,1) + DO I = 2, N + IF (DABS(F) < DABS(A(I,I))) F = A(I,I) + IF (DABS(E) <= DABS(A(I,I))) CYCLE + E = A(I,I) + END DO + EPSILP = EPSIL + IF (EPSILP <= 0) EPSILP = 1.0E-8 + RAT = E/F + IF (ABS(RAT) < EPSILP) GO TO 130 ! ! INVERT TRIANGULAR MATRIX - J = N - DO J1 = 1, N + J = N + DO J1 = 1, N ! CALL SLITE(2) - I = J - ISL2 = 1 - DO I1 = 1, J + I = J + ISL2 = 1 + DO I1 = 1, J ! CALL SLITET(2,K000FX) - IF (ISL2 == 0) K000FX = 2 - IF (ISL2 == 1) THEN - K000FX = 1 - ISL2 = 0 - ENDIF - SELECT CASE (K000FX) - CASE DEFAULT - A(I,J) = 1.0D0/A(I,I) - CASE (2) - KS = I + 1 - D = 0.0D0 - D = SUM(A(I,KS:J)*A(KS:J,J)) - A(I,J) = -D/A(I,I) - END SELECT - 1003 CONTINUE - I = I - 1 - END DO - J = J - 1 - END DO + IF (ISL2 == 0) K000FX = 2 + IF (ISL2 == 1) THEN + K000FX = 1 + ISL2 = 0 + ENDIF + SELECT CASE (K000FX) + CASE DEFAULT + A(I,J) = 1.0D0/A(I,I) + CASE (2) + KS = I + 1 + D = 0.0D0 + D = SUM(A(I,KS:J)*A(KS:J,J)) + A(I,J) = -D/A(I,I) + END SELECT + 1003 CONTINUE + I = I - 1 + END DO + J = J - 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,103,103),K000FX - + !103 CALL DVCHK(K000FX) ! GO TO (140,105),K000FX ! ! PREMULTIPLY EL BY INVERTED TRIANGULAR MATRIX - M = 1 - DO I = 1, N - DO J = 1, N - D = 0.0D0 - D = SUM(A(I,M:N)*EL(M:N,J)) - EL(I,J) = D - END DO - M = M + 1 - END DO + M = 1 + DO I = 1, N + DO J = 1, N + D = 0.0D0 + D = SUM(A(I,M:N)*EL(M:N,J)) + EL(I,J) = D + END DO + M = M + 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,123,123),K000FX ! ! RECOPY EL TO A - A(:N,:N) = EL(:N,:N) - ITEST = 0 + A(:N,:N) = EL(:N,:N) + ITEST = 0 !126 IF(INDSNL.EQ.1)CALL SLITE(2) - 126 CONTINUE - IF (INDSNL == 1) ISL2 = 1 - RETURN + 126 CONTINUE + IF (INDSNL == 1) ISL2 = 1 + RETURN ! - 130 CONTINUE - ITEST = 1 - GO TO 126 - 140 CONTINUE - ITEST = -1 - GO TO 126 - END SUBROUTINE BNDINV + 130 CONTINUE + ITEST = 1 + GO TO 126 + 140 CONTINUE + ITEST = -1 + GO TO 126 + END SUBROUTINE BNDINV diff --git a/src/appl/rbiotransform90/bndinv_I.f90 b/src/appl/rbiotransform90/bndinv_I.f90 index e1f850286..faeba5aa4 100644 --- a/src/appl/rbiotransform90/bndinv_I.f90 +++ b/src/appl/rbiotransform90/bndinv_I.f90 @@ -1,17 +1,17 @@ - MODULE bndinv_I + MODULE bndinv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bndinv (A, EL, N, DETERM, EPSIL, ITEST, NSIZE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: A - REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: EL - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(OUT) :: DETERM - REAL(DOUBLE), INTENT(IN) :: EPSIL - INTEGER, INTENT(OUT) :: ITEST - INTEGER, INTENT(IN) :: NSIZE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bndinv (A, EL, N, DETERM, EPSIL, ITEST, NSIZE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: A + REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: EL + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(OUT) :: DETERM + REAL(DOUBLE), INTENT(IN) :: EPSIL + INTEGER, INTENT(OUT) :: ITEST + INTEGER, INTENT(IN) :: NSIZE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/brkt.f90 b/src/appl/rbiotransform90/brkt.f90 index 2bb498d29..92b0f994c 100644 --- a/src/appl/rbiotransform90/brkt.f90 +++ b/src/appl/rbiotransform90/brkt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BRKT + SUBROUTINE BRKT ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE BRKT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE biorb_C @@ -22,46 +22,46 @@ SUBROUTINE BRKT !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! - - DO I = 1, NWII - DO J = 1, NWFF - IF (NAKII(I) /= NAKFF(J)) CYCLE + + DO I = 1, NWII + DO J = 1, NWFF + IF (NAKII(I) /= NAKFF(J)) CYCLE ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA = 0.0D0 + TA = 0.0D0 ! TA(1)=0.D0 - DO L = 2, MTP - TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + DO L = 2, MTP + TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - - BRAKET(I,J) = RESULT - + CALL QUAD (RESULT) + + BRAKET(I,J) = RESULT + WRITE (*, 9) '<', NPII(I), NHII(I), '|', NPFF(J), NHFF(J), '> =', & - BRAKET(I,J) - END DO - END DO + BRAKET(I,J) + END DO + END DO ! - 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) - - RETURN - END SUBROUTINE BRKT + 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) + + RETURN + END SUBROUTINE BRKT diff --git a/src/appl/rbiotransform90/brkt_I.f90 b/src/appl/rbiotransform90/brkt_I.f90 index 7bdeadb75..a01fd0870 100644 --- a/src/appl/rbiotransform90/brkt_I.f90 +++ b/src/appl/rbiotransform90/brkt_I.f90 @@ -1,9 +1,9 @@ - MODULE brkt_I + MODULE brkt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE brkt - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE brkt + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/citrag.f90 b/src/appl/rbiotransform90/citrag.f90 index 655504e88..2193bc7d8 100644 --- a/src/appl/rbiotransform90/citrag.f90 +++ b/src/appl/rbiotransform90/citrag.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * ! * - SUBROUTINE CITRAG(CIIN, NCSF, NCIV, L, NSHL, T, NIN, NTESTG, CIOUT, SCR) + SUBROUTINE CITRAG(CIIN, NCSF, NCIV, L, NSHL, T, NIN, NTESTG, CIOUT, SCR) ! * ! Calculate the action of the operator * ! * @@ -33,117 +33,117 @@ SUBROUTINE CITRAG(CIIN, NCSF, NCIV, L, NSHL, T, NIN, NTESTG, CIOUT, SCR) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE sbdat1_C USE orb_C ! !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE wrtmat_I - USE scalve_I - USE tiinig_I - USE ti1tv_I - USE vecsum_I + USE wrtmat_I + USE scalve_I + USE tiinig_I + USE ti1tv_I + USE vecsum_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCSF - INTEGER :: NCIV - INTEGER :: L - INTEGER :: NSHL - INTEGER, INTENT(IN) :: NIN - INTEGER :: NTESTG - REAL(DOUBLE) :: CIIN(NCSF,NCIV) - REAL(DOUBLE) :: T(NSHL,NSHL) - REAL(DOUBLE) :: CIOUT(NCSF,NCIV) - REAL(DOUBLE) :: SCR(NCSF,NCIV) + INTEGER :: NCSF + INTEGER :: NCIV + INTEGER :: L + INTEGER :: NSHL + INTEGER, INTENT(IN) :: NIN + INTEGER :: NTESTG + REAL(DOUBLE) :: CIIN(NCSF,NCIV) + REAL(DOUBLE) :: T(NSHL,NSHL) + REAL(DOUBLE) :: CIOUT(NCSF,NCIV) + REAL(DOUBLE) :: SCR(NCSF,NCIV) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTESTL, NTEST, IIN, IPOT, I, N - REAL(DOUBLE) :: FACTOR, TII, XNFACI + INTEGER :: NTESTL, NTEST, IIN, IPOT, I, N + REAL(DOUBLE) :: FACTOR, TII, XNFACI !----------------------------------------------- ! - - NTESTL = 0 - NTEST = MAX(NTESTG,NTESTL) - NTEST = 0 - -! - IF (NTEST >= 10) THEN - WRITE (6, *) - WRITE (6, *) ' ***************' - WRITE (6, *) ' Entering CITRAG' - WRITE (6, *) ' ***************' - WRITE (6, *) - ENDIF - IF (NTEST >= 100) THEN + + NTESTL = 0 + NTEST = MAX(NTESTG,NTESTL) + NTEST = 0 + +! + IF (NTEST >= 10) THEN + WRITE (6, *) + WRITE (6, *) ' ***************' + WRITE (6, *) ' Entering CITRAG' + WRITE (6, *) ' ***************' + WRITE (6, *) + ENDIF + IF (NTEST >= 100) THEN WRITE (6, *) ' Input CI vectors' - CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) ' Transformation matrix T' - CALL WRTMAT (T, NSHL, NSHL, NSHL, NSHL) - ENDIF + CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) ' Transformation matrix T' + CALL WRTMAT (T, NSHL, NSHL, NSHL, NSHL) + ENDIF ! !. Factor from inactive shells ! - IF (NIN /= 0) THEN - FACTOR = 1.0D0 - DO IIN = 1, NIN - FACTOR = FACTOR*T(IIN,IIN) - END DO + IF (NIN /= 0) THEN + FACTOR = 1.0D0 + DO IIN = 1, NIN + FACTOR = FACTOR*T(IIN,IIN) + END DO ! ! IPOT = 2*(2*L+1) (number of m_lm_s. This should be replaced ! by (2j+1) corresponding to L) ! - IPOT = 2*IABS(NAK(NSHLP(L,IIN))) - FACTOR = FACTOR**IPOT - CALL SCALVE (CIIN, FACTOR, NCIV*NCSF) - ENDIF - IF (NIN == NSHL) CALL COPVEC (CIIN, CIOUT, NCIV*NCSF) + IPOT = 2*IABS(NAK(NSHLP(L,IIN))) + FACTOR = FACTOR**IPOT + CALL SCALVE (CIIN, FACTOR, NCIV*NCSF) + ENDIF + IF (NIN == NSHL) CALL COPVEC (CIIN, CIOUT, NCIV*NCSF) ! - DO I = NIN + 1, NSHL - IF (NTEST >= 100) WRITE (6, *) ' Loop I,L = ', I, L + DO I = NIN + 1, NSHL + IF (NTEST >= 100) WRITE (6, *) ' Loop I,L = ', I, L ! !. The diagonal contribution ! - TII = T(I,I) - CALL TIINIG (CIIN, NCSF, NCIV, I, L, TII, CIOUT, NTESTG) + TII = T(I,I) + CALL TIINIG (CIIN, NCSF, NCIV, I, L, TII, CIOUT, NTESTG) ! IF (LWORK2.LT.NCIV*NCSF) THEN ! WRITE(*,*) 'In CITRAG: Dimension of LWORK2 must be', ! & 'increased to at least',NCIV*NCSF ! ENDIF - CALL COPVEC (CIOUT, SCR, NCIV*NCSF) + CALL COPVEC (CIOUT, SCR, NCIV*NCSF) ! !. Off diagonal contributions ! - XNFACI = 1.0D0 - DO N = 1, 2*IABS(NAK(NSHLP(L,I))) - IF (NTEST >= 100) WRITE (6, *) ' Loop N = ', N + XNFACI = 1.0D0 + DO N = 1, 2*IABS(NAK(NSHLP(L,I))) + IF (NTEST >= 100) WRITE (6, *) ' Loop N = ', N ! ! T ** (N-1) is supposed to be in SCR, copy to CIIN ! and apply S ! - CALL COPVEC (SCR, CIIN, NCIV*NCSF) - CALL TI1TV (CIIN, NCSF, NCIV, I, L, T(1,I), NSHL, SCR, NTESTG) - XNFACI = XNFACI/FLOAT(N) - CALL VECSUM (CIOUT, CIOUT, SCR, 1.0D0, XNFACI, NCIV*NCSF) - END DO - CALL COPVEC (CIOUT, CIIN, NCIV*NCSF) + CALL COPVEC (SCR, CIIN, NCIV*NCSF) + CALL TI1TV (CIIN, NCSF, NCIV, I, L, T(1,I), NSHL, SCR, NTESTG) + XNFACI = XNFACI/FLOAT(N) + CALL VECSUM (CIOUT, CIOUT, SCR, 1.0D0, XNFACI, NCIV*NCSF) + END DO + CALL COPVEC (CIOUT, CIIN, NCIV*NCSF) ! - END DO + END DO ! - IF (NTEST >= 100) THEN - WRITE (6, *) ' Output CI vectors L = ', L - CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) - ENDIF + IF (NTEST >= 100) THEN + WRITE (6, *) ' Output CI vectors L = ', L + CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) + ENDIF ! - RETURN - END SUBROUTINE CITRAG + RETURN + END SUBROUTINE CITRAG diff --git a/src/appl/rbiotransform90/citrag_I.f90 b/src/appl/rbiotransform90/citrag_I.f90 index 0c5bcc5d2..a85eaa9e7 100644 --- a/src/appl/rbiotransform90/citrag_I.f90 +++ b/src/appl/rbiotransform90/citrag_I.f90 @@ -1,20 +1,20 @@ - MODULE citrag_I + MODULE citrag_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE citrag (CIIN, NCSF, NCIV, L, NSHL, T, NIN, NTESTG, CIOUT, SCR) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIIN - INTEGER, INTENT(IN) :: NCSF - INTEGER, INTENT(IN) :: NCIV - INTEGER, INTENT(IN) :: L - INTEGER, INTENT(IN) :: NSHL - REAL(DOUBLE), DIMENSION(NSHL,NSHL), INTENT(IN) :: T - INTEGER, INTENT(IN) :: NIN - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIOUT - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: SCR - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE citrag (CIIN, NCSF, NCIV, L, NSHL, T, NIN, NTESTG, CIOUT, SCR) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIIN + INTEGER, INTENT(IN) :: NCSF + INTEGER, INTENT(IN) :: NCIV + INTEGER, INTENT(IN) :: L + INTEGER, INTENT(IN) :: NSHL + REAL(DOUBLE), DIMENSION(NSHL,NSHL), INTENT(IN) :: T + INTEGER, INTENT(IN) :: NIN + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIOUT + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: SCR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/copvec.f90 b/src/appl/rbiotransform90/copvec.f90 index e95b3c9c3..9157fef48 100644 --- a/src/appl/rbiotransform90/copvec.f90 +++ b/src/appl/rbiotransform90/copvec.f90 @@ -3,24 +3,24 @@ ! C O P V E C ! ------------------------------------------------------------------ ! - SUBROUTINE COPVEC(FROM, TO, NDIM) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer + SUBROUTINE COPVEC(FROM, TO, NDIM) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM + INTEGER, INTENT(IN) :: NDIM REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO ! - TO(:NDIM) = FROM(:NDIM) + TO(:NDIM) = FROM(:NDIM) ! - RETURN - END SUBROUTINE COPVEC + RETURN + END SUBROUTINE COPVEC diff --git a/src/appl/rbiotransform90/copvec_I.f90 b/src/appl/rbiotransform90/copvec_I.f90 index c653de3ef..175bbcea4 100644 --- a/src/appl/rbiotransform90/copvec_I.f90 +++ b/src/appl/rbiotransform90/copvec_I.f90 @@ -1,13 +1,13 @@ - MODULE copvec_I + MODULE copvec_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE copvec (FROM, TO, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM - REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE copvec (FROM, TO, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM + REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/fname.f90 b/src/appl/rbiotransform90/fname.f90 index 86d848951..de9e4233f 100644 --- a/src/appl/rbiotransform90/fname.f90 +++ b/src/appl/rbiotransform90/fname.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE FNAME(NAME) + SUBROUTINE FNAME(NAME) ! * ! Determines the name of the initial and final states * ! In addition this subroutine determines which J symmetries * @@ -9,8 +9,8 @@ SUBROUTINE FNAME(NAME) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:19:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:19:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! C O M M O N B l o c k s @@ -19,40 +19,40 @@ SUBROUTINE FNAME(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I - LOGICAL :: YES + INTEGER :: J, I + LOGICAL :: YES !----------------------------------------------- ! ! ! Obtain the names of the initial and final state files ! - 1 CONTINUE - WRITE (6, *) ' Name of the Initial state' - READ (*, '(A)') NAME(1) - - WRITE (6, *) ' Name of the Final state' - READ (*, '(A)') NAME(2) + 1 CONTINUE + WRITE (6, *) ' Name of the Initial state' + READ (*, '(A)') NAME(1) + + WRITE (6, *) ' Name of the Final state' + READ (*, '(A)') NAME(2) ! - J = INDEX(NAME(1),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(1),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! - J = INDEX(NAME(2),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(2),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! Per april 2007 ! Check if the initial and final states are identical. @@ -71,23 +71,23 @@ SUBROUTINE FNAME(NAME) END IF ! end Per 2007 - WRITE (6, *) ' Transformation of all J symmetries?' - YES = GETYN() - IF (YES) THEN - NTRANS = 0 - ELSE - NTRANS = 1 - WRITE (6, *) ' Number of initial state J symmetries to be transformed' - READ (*, *) JQJ1 - WRITE (6, *) ' Give the J symmetries in the form 2*J' - READ (*, *) (ITJQJ1(I),I=1,JQJ1) - ITJQJ1(:JQJ1) = ITJQJ1(:JQJ1) + 1 - WRITE (6, *) ' Number of final state J symmetries to be transformed' - READ (*, *) JQJ2 - WRITE (6, *) ' Give the J symmetries in the form 2*J' - READ (*, *) (ITJQJ2(I),I=1,JQJ2) - ITJQJ2(:JQJ2) = ITJQJ2(:JQJ2) + 1 - ENDIF - - RETURN - END SUBROUTINE FNAME + WRITE (6, *) ' Transformation of all J symmetries?' + YES = GETYN() + IF (YES) THEN + NTRANS = 0 + ELSE + NTRANS = 1 + WRITE (6, *) ' Number of initial state J symmetries to be transformed' + READ (*, *) JQJ1 + WRITE (6, *) ' Give the J symmetries in the form 2*J' + READ (*, *) (ITJQJ1(I),I=1,JQJ1) + ITJQJ1(:JQJ1) = ITJQJ1(:JQJ1) + 1 + WRITE (6, *) ' Number of final state J symmetries to be transformed' + READ (*, *) JQJ2 + WRITE (6, *) ' Give the J symmetries in the form 2*J' + READ (*, *) (ITJQJ2(I),I=1,JQJ2) + ITJQJ2(:JQJ2) = ITJQJ2(:JQJ2) + 1 + ENDIF + + RETURN + END SUBROUTINE FNAME diff --git a/src/appl/rbiotransform90/fname_I.f90 b/src/appl/rbiotransform90/fname_I.f90 index 25e5f6eb0..9b49cbb7a 100644 --- a/src/appl/rbiotransform90/fname_I.f90 +++ b/src/appl/rbiotransform90/fname_I.f90 @@ -1,10 +1,10 @@ - MODULE fname_I + MODULE fname_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fname (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE fname (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/genmcp.f90 b/src/appl/rbiotransform90/genmcp.f90 index 6b7caccdf..f010b73d3 100644 --- a/src/appl/rbiotransform90/genmcp.f90 +++ b/src/appl/rbiotransform90/genmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GENMCP(NAME, IC, NTESTG, INPCI) + SUBROUTINE GENMCP(NAME, IC, NTESTG, INPCI) ! * ! Entry routine for GENMCP. Controls the computation of the * ! one-particle coupling coefficients. * @@ -8,50 +8,50 @@ SUBROUTINE GENMCP(NAME, IC, NTESTG, INPCI) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcslb_I - USE factt_I - USE mcpout_I - USE mcpin_I + USE setcslb_I + USE factt_I + USE mcpout_I + USE mcpin_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IC - INTEGER :: NTESTG - INTEGER :: INPCI - CHARACTER :: NAME*24 + INTEGER :: IC + INTEGER :: NTESTG + INTEGER :: INPCI + CHARACTER :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCORE_NOT_USED + INTEGER :: NCORE_NOT_USED !----------------------------------------------- ! - WRITE (6, *) - WRITE (6, *) 'GENMCP: Execution begins for ', NAME + WRITE (6, *) + WRITE (6, *) 'GENMCP: Execution begins for ', NAME ! ! Open, check, load data from, and close the csl file ! - CALL SETCSLB (NAME, NCORE_NOT_USED,3) + CALL SETCSLB (NAME, NCORE_NOT_USED,3) ! ! Set up the table of logarithms of factorials for use by ! angular modules ! - CALL FACTT + CALL FACTT ! ! Proceed with the generation of MCP coefficients ! - CALL MCPOUT (NAME, IC, NTESTG, INPCI) - CALL MCPIN (NAME, IC, NTESTG, INPCI) + CALL MCPOUT (NAME, IC, NTESTG, INPCI) + CALL MCPIN (NAME, IC, NTESTG, INPCI) ! ! Print completion message ! - WRITE (6, *) + WRITE (6, *) ! - RETURN - END SUBROUTINE GENMCP + RETURN + END SUBROUTINE GENMCP diff --git a/src/appl/rbiotransform90/genmcp_I.f90 b/src/appl/rbiotransform90/genmcp_I.f90 index 9838b9fac..3cb205b09 100644 --- a/src/appl/rbiotransform90/genmcp_I.f90 +++ b/src/appl/rbiotransform90/genmcp_I.f90 @@ -1,13 +1,13 @@ - MODULE genmcp_I + MODULE genmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genmcp (NAME, IC, NTESTG, INPCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER :: IC - INTEGER :: NTESTG - INTEGER :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE genmcp (NAME, IC, NTESTG, INPCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER :: IC + INTEGER :: NTESTG + INTEGER :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/getmix.f90 b/src/appl/rbiotransform90/getmix.f90 index 869698d6f..26dbaff70 100644 --- a/src/appl/rbiotransform90/getmix.f90 +++ b/src/appl/rbiotransform90/getmix.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETMIX(NAME, INPCI, IBLK) + SUBROUTINE GETMIX(NAME, INPCI, IBLK) ! * ! Open, check, load data from and close the rscf.mix file. * ! * @@ -9,20 +9,20 @@ SUBROUTINE GETMIX(NAME, INPCI, IBLK) ! Written by Farid A. Parpia Last revision: 25 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE def_C USE orb_C, ONLY: ncf, nw, iqa - USE EIGV_C - USE PRNT_C - USE SYMA_C - USE BLK_C + USE EIGV_C + USE PRNT_C + USE SYMA_C + USE BLK_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -30,69 +30,69 @@ SUBROUTINE GETMIX(NAME, INPCI, IBLK) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INPCI - INTEGER, INTENT(IN) :: IBLK - CHARACTER, INTENT(IN) :: NAME*24 + INTEGER, INTENT(IN) :: INPCI + INTEGER, INTENT(IN) :: IBLK + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IK, J, IOS, NB, IATJP, IASPA, I - CHARACTER :: G92MIX*6 + INTEGER :: IK, J, IOS, NB, IATJP, IASPA, I + CHARACTER :: G92MIX*6 !----------------------------------------------- - - IK = 30 - IF (IBLK == 1) THEN - J = INDEX(NAME,' ') - IF (INPCI == 0) THEN + + IK = 30 + IF (IBLK == 1) THEN + J = INDEX(NAME,' ') + IF (INPCI == 0) THEN OPEN(UNIT=IK, FILE=NAME(1:J-1)//'.cm', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ELSE + 'OLD', POSITION='asis') + ELSE OPEN(UNIT=IK, FILE=NAME(1:J-1)//'.m', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ENDIF - - READ (IK, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (6, *) 'File', IK, 'Not a GRASP MIXing Coefficients File;' - CLOSE(IK) - STOP - ENDIF + 'OLD', POSITION='asis') + ENDIF + + READ (IK, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (6, *) 'File', IK, 'Not a GRASP MIXing Coefficients File;' + CLOSE(IK) + STOP + ENDIF ! - READ (IK) NELECTOT, NCFTOT, NWTOT, NVECTOT, NVECSIZTOT, NBLOCK1 - IF (NELEC/=NELECTOT .OR. NW/=NWTOT) THEN + READ (IK) NELECTOT, NCFTOT, NWTOT, NVECTOT, NVECSIZTOT, NBLOCK1 + IF (NELEC/=NELECTOT .OR. NW/=NWTOT) THEN ! : (NCF .NE. NCFT) .OR. - WRITE (6, *) 'File', IK, 'is not an' - WRITE (6, *) ' appropriate to Coefficients file' - CLOSE(IK) - STOP - ENDIF - ENDIF + WRITE (6, *) 'File', IK, 'is not an' + WRITE (6, *) ' appropriate to Coefficients file' + CLOSE(IK) + STOP + ENDIF + ENDIF ! ! Load data from the rscf.mix file ! - WRITE (6, *) 'Loading MIXing Coefficients File ...' + WRITE (6, *) 'Loading MIXing Coefficients File ...' ! - READ (IK) NB, NCF, NVEC, IATJP, IASPA - CALL ALLOC (EVAL, NVEC, 'EVAL', 'GETMIX') - CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'GETMIX') - CALL ALLOC (IVEC, NVEC, 'IVEC', 'GETMIX') - CALL ALLOC (IATJPO, NVEC, 'IATJPO', 'GETMIX') - CALL ALLOC (IASPAR, NVEC, 'IASPAR', 'GETMIX') + READ (IK) NB, NCF, NVEC, IATJP, IASPA + CALL ALLOC (EVAL, NVEC, 'EVAL', 'GETMIX') + CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'GETMIX') + CALL ALLOC (IVEC, NVEC, 'IVEC', 'GETMIX') + CALL ALLOC (IATJPO, NVEC, 'IATJPO', 'GETMIX') + CALL ALLOC (IASPAR, NVEC, 'IASPAR', 'GETMIX') ! ! These arrays are deallocated in mcp ! - READ (IK) (IVEC(I),I=1,NVEC) + READ (IK) (IVEC(I),I=1,NVEC) ! READ (IK) (IATJPO(I),IASPAR(I),I = 1,NVEC) - IATJPO(:NVEC) = IATJP - IASPAR(:NVEC) = IASPA - READ (IK) EAV, (EVAL(I),I=1,NVEC) - READ (IK) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + IATJPO(:NVEC) = IATJP + IASPAR(:NVEC) = IASPA + READ (IK) EAV, (EVAL(I),I=1,NVEC) + READ (IK) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) ! - WRITE (6, *) ' ... load complete;' + WRITE (6, *) ' ... load complete;' ! ! Close the rscf.mix file ! ! CLOSE (IK) ! - RETURN - END SUBROUTINE GETMIX + RETURN + END SUBROUTINE GETMIX diff --git a/src/appl/rbiotransform90/getmix_I.f90 b/src/appl/rbiotransform90/getmix_I.f90 index 47576ddc7..64a32efa9 100644 --- a/src/appl/rbiotransform90/getmix_I.f90 +++ b/src/appl/rbiotransform90/getmix_I.f90 @@ -1,12 +1,12 @@ - MODULE getmix_I + MODULE getmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getmix (NAME, INPCI, IBLK) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: INPCI - INTEGER, INTENT(IN) :: IBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getmix (NAME, INPCI, IBLK) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: INPCI + INTEGER, INTENT(IN) :: IBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/gets.f90 b/src/appl/rbiotransform90/gets.f90 index 852c00203..d82d99457 100644 --- a/src/appl/rbiotransform90/gets.f90 +++ b/src/appl/rbiotransform90/gets.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETS(S, NSHLI, NSHLF) + SUBROUTINE GETS(S, NSHLI, NSHLF) ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE GETS(S, NSHLI, NSHLF) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE orb_C @@ -23,51 +23,51 @@ SUBROUTINE GETS(S, NSHLI, NSHLF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I - USE wrtmat_I + USE quad_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NSHLI - INTEGER :: NSHLF - REAL(DOUBLE) :: S(NSHLI,NSHLF) + INTEGER :: NSHLI + INTEGER :: NSHLF + REAL(DOUBLE) :: S(NSHLI,NSHLF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! - DO I = 1, NSHLI - DO J = 1, NSHLF + DO I = 1, NSHLI + DO J = 1, NSHLF ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.D0 - DO L = 2, MTP + TA(1) = 0.D0 + DO L = 2, MTP TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - S(I,J) = RESULT - END DO - END DO + CALL QUAD (RESULT) + S(I,J) = RESULT + END DO + END DO ! ! Print out ! - WRITE (*, *) '********************' - WRITE (*, *) ' S matrix from GETS' - WRITE (*, *) '********************' - - CALL WRTMAT (S, NSHLI, NSHLF, NSHLI, NSHLF) + WRITE (*, *) '********************' + WRITE (*, *) ' S matrix from GETS' + WRITE (*, *) '********************' + + CALL WRTMAT (S, NSHLI, NSHLF, NSHLI, NSHLF) ! - RETURN - END SUBROUTINE GETS + RETURN + END SUBROUTINE GETS diff --git a/src/appl/rbiotransform90/gets_I.f90 b/src/appl/rbiotransform90/gets_I.f90 index da978da1e..7b7cc88d9 100644 --- a/src/appl/rbiotransform90/gets_I.f90 +++ b/src/appl/rbiotransform90/gets_I.f90 @@ -1,13 +1,13 @@ - MODULE gets_I + MODULE gets_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE gets (S, NSHLI, NSHLF) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NSHLI,NSHLF), INTENT(OUT) :: S - INTEGER, INTENT(IN) :: NSHLI - INTEGER, INTENT(IN) :: NSHLF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE gets (S, NSHLI, NSHLF) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NSHLI,NSHLF), INTENT(OUT) :: S + INTEGER, INTENT(IN) :: NSHLI + INTEGER, INTENT(IN) :: NSHLF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/ichkq1.f90 b/src/appl/rbiotransform90/ichkq1.f90 index 9631865b5..1e8a58ed9 100644 --- a/src/appl/rbiotransform90/ichkq1.f90 +++ b/src/appl/rbiotransform90/ichkq1.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ICHKQ1 (JA, JB) + INTEGER FUNCTION ICHKQ1 (JA, JB) ! * ! This routine is to check the occupation condition for one electron * ! operator. * @@ -10,43 +10,43 @@ INTEGER FUNCTION ICHKQ1 (JA, JB) ! Yu Zou Last revision: 8/16/00 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, ONLY: ncf,nw,iqa !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB + INTEGER :: JA + INTEGER :: JB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, I, IQA, IQB + INTEGER :: K, I, IQA, IQB !----------------------------------------------- ! ! - ICHKQ1 = 0 - K = 0 - DO I = 1, NW - IQA = IQ(I,JA) - IQB = IQ(I,JB) - IF (IQA == IQB) CYCLE - K = K + 1 - IF (K > 2) RETURN - IF (IABS(IQA - IQB) <= 1) CYCLE - RETURN - END DO - IF (K==2 .OR. K==0) ICHKQ1 = 1 - RETURN - END FUNCTION ICHKQ1 + ICHKQ1 = 0 + K = 0 + DO I = 1, NW + IQA = IQ(I,JA) + IQB = IQ(I,JB) + IF (IQA == IQB) CYCLE + K = K + 1 + IF (K > 2) RETURN + IF (IABS(IQA - IQB) <= 1) CYCLE + RETURN + END DO + IF (K==2 .OR. K==0) ICHKQ1 = 1 + RETURN + END FUNCTION ICHKQ1 diff --git a/src/appl/rbiotransform90/ichkq1_I.f90 b/src/appl/rbiotransform90/ichkq1_I.f90 index 8312b6842..506bf0913 100644 --- a/src/appl/rbiotransform90/ichkq1_I.f90 +++ b/src/appl/rbiotransform90/ichkq1_I.f90 @@ -1,11 +1,11 @@ - MODULE ichkq1_I + MODULE ichkq1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ichkq1 (JA, JB) - INTEGER :: JA - INTEGER :: JB - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ichkq1 (JA, JB) + INTEGER :: JA + INTEGER :: JB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/ielsum.f90 b/src/appl/rbiotransform90/ielsum.f90 index 926caa4d5..2d5c67de7 100644 --- a/src/appl/rbiotransform90/ielsum.f90 +++ b/src/appl/rbiotransform90/ielsum.f90 @@ -3,31 +3,31 @@ ! I E L S U M ! ------------------------------------------------------------------ ! - INTEGER FUNCTION IELSUM (IVEC, NELMNT) + INTEGER FUNCTION IELSUM (IVEC, NELMNT) ! ! Sum elements of integer array ! -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NELMNT - INTEGER, INTENT(IN) :: IVEC(*) + INTEGER, INTENT(IN) :: NELMNT + INTEGER, INTENT(IN) :: IVEC(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISUM, IEL + INTEGER :: ISUM, IEL !----------------------------------------------- ! - ISUM = 0 - ISUM = SUM(IVEC(:NELMNT)) + ISUM = 0 + ISUM = SUM(IVEC(:NELMNT)) ! - IELSUM = ISUM + IELSUM = ISUM ! - RETURN - END FUNCTION IELSUM + RETURN + END FUNCTION IELSUM diff --git a/src/appl/rbiotransform90/ielsum_I.f90 b/src/appl/rbiotransform90/ielsum_I.f90 index fc1e39205..aa0fc51f4 100644 --- a/src/appl/rbiotransform90/ielsum_I.f90 +++ b/src/appl/rbiotransform90/ielsum_I.f90 @@ -1,11 +1,11 @@ - MODULE ielsum_I + MODULE ielsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ielsum (IVEC, NELMNT) - INTEGER, DIMENSION(*), INTENT(IN) :: IVEC - INTEGER, INTENT(IN) :: NELMNT - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ielsum (IVEC, NELMNT) + INTEGER, DIMENSION(*), INTENT(IN) :: IVEC + INTEGER, INTENT(IN) :: NELMNT + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/ifnmnx.f90 b/src/appl/rbiotransform90/ifnmnx.f90 index d47aace30..eecdb3fb2 100644 --- a/src/appl/rbiotransform90/ifnmnx.f90 +++ b/src/appl/rbiotransform90/ifnmnx.f90 @@ -3,7 +3,7 @@ ! I F N M N X ! ------------------------------------------------------------------ ! - INTEGER FUNCTION IFNMNX (IVEC, NEL, IMXMN) + INTEGER FUNCTION IFNMNX (IVEC, NEL, IMXMN) ! ! Smallest or largest value of integer array ! @@ -14,30 +14,30 @@ INTEGER FUNCTION IFNMNX (IVEC, NEL, IMXMN) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NEL - INTEGER , INTENT(IN) :: IMXMN - INTEGER , INTENT(IN) :: IVEC(NEL) + INTEGER , INTENT(IN) :: NEL + INTEGER , INTENT(IN) :: IMXMN + INTEGER , INTENT(IN) :: IVEC(NEL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IVAL, IEL, NTEST + INTEGER :: IVAL, IEL, NTEST !----------------------------------------------- ! - IVAL = IVEC(1) - IF (IMXMN == 1) THEN - IVAL = MAX0(MAXVAL(IVEC(2:NEL)),IVAL) - ELSE IF (IMXMN == 2) THEN - IVAL = MIN0(MINVAL(IVEC(2:NEL)),IVAL) - ELSE - WRITE (6, *) ' Stop in IFNMNX ' - WRITE (6, *) ' Improper calue of IMXMN ', IMXMN - STOP 'IFNMNX' - ENDIF + IVAL = IVEC(1) + IF (IMXMN == 1) THEN + IVAL = MAX0(MAXVAL(IVEC(2:NEL)),IVAL) + ELSE IF (IMXMN == 2) THEN + IVAL = MIN0(MINVAL(IVEC(2:NEL)),IVAL) + ELSE + WRITE (6, *) ' Stop in IFNMNX ' + WRITE (6, *) ' Improper calue of IMXMN ', IMXMN + STOP 'IFNMNX' + ENDIF ! - IFNMNX = IVAL + IFNMNX = IVAL ! - NTEST = 0 - IF (NTEST /= 0) WRITE (6, *) ' Value returned from IFNMNX', IFNMNX + NTEST = 0 + IF (NTEST /= 0) WRITE (6, *) ' Value returned from IFNMNX', IFNMNX ! - RETURN - END FUNCTION IFNMNX + RETURN + END FUNCTION IFNMNX diff --git a/src/appl/rbiotransform90/ifnmnx_I.f90 b/src/appl/rbiotransform90/ifnmnx_I.f90 index 5437d5c1d..49e4bee9b 100644 --- a/src/appl/rbiotransform90/ifnmnx_I.f90 +++ b/src/appl/rbiotransform90/ifnmnx_I.f90 @@ -1,13 +1,13 @@ - MODULE ifnmnx_I + MODULE ifnmnx_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ifnmnx (IVEC, NEL, IMXMN) - INTEGER, DIMENSION(NEL), INTENT(IN) :: IVEC - INTEGER, INTENT(IN) :: NEL - INTEGER, INTENT(IN) :: IMXMN + INTEGER FUNCTION ifnmnx (IVEC, NEL, IMXMN) + INTEGER, DIMENSION(NEL), INTENT(IN) :: IVEC + INTEGER, INTENT(IN) :: NEL + INTEGER, INTENT(IN) :: IMXMN !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/inprod.f90 b/src/appl/rbiotransform90/inprod.f90 index fd2649997..211d8f507 100644 --- a/src/appl/rbiotransform90/inprod.f90 +++ b/src/appl/rbiotransform90/inprod.f90 @@ -3,30 +3,30 @@ ! I N P R O D ! ------------------------------------------------------------------ ! - REAL(KIND(0.0D0)) FUNCTION INPROD (A, B, NDIM) + REAL(KIND(0.0D0)) FUNCTION INPROD (A, B, NDIM) ! CALCULATE SCALAR PRODUCT BETWEEN TO VECTORS A,B !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(*) - REAL(DOUBLE), INTENT(IN) :: B(*) + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(*) + REAL(DOUBLE), INTENT(IN) :: B(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! - INPROD = DOT_PRODUCT(A(:NDIM),B(:NDIM)) + INPROD = DOT_PRODUCT(A(:NDIM),B(:NDIM)) ! - RETURN - END FUNCTION INPROD + RETURN + END FUNCTION INPROD diff --git a/src/appl/rbiotransform90/inprod_I.f90 b/src/appl/rbiotransform90/inprod_I.f90 index 7a11c9e2e..0cfed6dde 100644 --- a/src/appl/rbiotransform90/inprod_I.f90 +++ b/src/appl/rbiotransform90/inprod_I.f90 @@ -1,13 +1,13 @@ - MODULE inprod_I + MODULE inprod_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION inprod (A, B, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: B - INTEGER, INTENT(IN) :: NDIM - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION inprod (A, B, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: B + INTEGER, INTENT(IN) :: NDIM + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/intrpqf.f90 b/src/appl/rbiotransform90/intrpqf.f90 index bf20a798a..a24048493 100644 --- a/src/appl/rbiotransform90/intrpqf.f90 +++ b/src/appl/rbiotransform90/intrpqf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) + SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! * ! This subprogram interpolates the arrays PA(1:MA), QA(1:MA), * ! tabulated on grid RA(1:MA) into the COMMON arrays PF(1:MF(J),J), * @@ -13,15 +13,15 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! Written by Farid A Parpia, at Oxford Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEBUG_C + USE DEBUG_C USE biorb_C USE orb_C USE def_C, ONLY:accy @@ -30,32 +30,32 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rintff_I + USE rintff_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MA - INTEGER :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + INTEGER, INTENT(IN) :: MA + INTEGER :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 13 + INTEGER, PARAMETER :: MXORD = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, MFJ, NRSTLO, KOUNT, IROW, K, NRSTHI, LLO, LHI, LOCNXT, & - ILIROK, ILDIAG, ILOTHR, MFJP1 - REAL(DOUBLE), DIMENSION(MXORD) :: X, DX - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ + ILIROK, ILDIAG, ILOTHR, MFJP1 + REAL(DOUBLE), DIMENSION(MXORD) :: X, DX + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ REAL(DOUBLE) :: RAMA, RN, XBAR, PESTL, QESTL, DIFF, DIFFT, DXKMN1, DXIROW& - , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC - LOGICAL :: SET - LOGICAL, DIMENSION(NNNP) :: USED + , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC + LOGICAL :: SET + LOGICAL, DIMENSION(NNNP) :: USED !----------------------------------------------- ! ! MXORD is the maximum order of the interpolation @@ -67,177 +67,177 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! ! Initialization ! - RAMA = RA(MA) - RN = R(N) + RAMA = RA(MA) + RN = R(N) ! ! This is always true in GRASP ! - PFFF(1,J) = 0.0D00 - QFFF(1,J) = 0.0D00 + PFFF(1,J) = 0.0D00 + QFFF(1,J) = 0.0D00 ! ! Checks ! - IF (RAMA > RN) THEN - WRITE (*, 300) RN, RAMA - STOP - ENDIF + IF (RAMA > RN) THEN + WRITE (*, 300) RN, RAMA + STOP + ENDIF ! ! Determine end of grid ! - I = N - 1 CONTINUE - I = I - 1 - IF (R(I) <= RAMA) THEN - MFJ = I - ELSE - GO TO 1 - ENDIF - MFFF(J) = MFJ + I = N + 1 CONTINUE + I = I - 1 + IF (R(I) <= RAMA) THEN + MFJ = I + ELSE + GO TO 1 + ENDIF + MFFF(J) = MFJ ! ! Overall initialization for interpolation ! - NRSTLO = 0 - KOUNT = 0 + NRSTLO = 0 + KOUNT = 0 ! ! Perform interpolation ! - DO I = 2, MFJ + DO I = 2, MFJ ! ! Initialization for interpolation ! - XBAR = R(I) - IROW = 0 - PESTL = 0.0D00 - QESTL = 0.0D00 + XBAR = R(I) + IROW = 0 + PESTL = 0.0D00 + QESTL = 0.0D00 ! ! Determine the nearest two grid points bounding the present ! grid point ! - 2 CONTINUE - K = NRSTLO + 1 - IF (RA(K) < XBAR) THEN - NRSTLO = K - GO TO 2 - ELSE - NRSTHI = K - ENDIF + 2 CONTINUE + K = NRSTLO + 1 + IF (RA(K) < XBAR) THEN + NRSTLO = K + GO TO 2 + ELSE + NRSTHI = K + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,MA) - USED(LLO:LHI) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,MA) + USED(LLO:LHI) = .FALSE. ! ! Determine next-nearest grid point ! - 4 CONTINUE - IROW = IROW + 1 - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,MA) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K)) CYCLE - IF (.NOT.SET) THEN - DIFF = RA(K) - XBAR - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = RA(K) - XBAR - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT) = .TRUE. - X(IROW) = RA(LOCNXT) - DX(IROW) = DIFF + 4 CONTINUE + IROW = IROW + 1 + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,MA) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K)) CYCLE + IF (.NOT.SET) THEN + DIFF = RA(K) - XBAR + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = RA(K) - XBAR + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT) = .TRUE. + X(IROW) = RA(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLYP(ILIROK) = PA(LOCNXT) - POLYQ(ILIROK) = QA(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) - DXKMN1 = DX(K-1) - DXIROW = DX(IROW) - FACTOR = 1.0D00/(X(IROW)-X(K-1)) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLYP(ILIROK) = PA(LOCNXT) + POLYQ(ILIROK) = QA(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) + DXKMN1 = DX(K-1) + DXIROW = DX(IROW) + FACTOR = 1.0D00/(X(IROW)-X(K-1)) POLYP(ILIROK) = (POLYP(ILDIAG)*DXIROW-POLYP(ILOTHR)*DXKMN1)*& - FACTOR + FACTOR POLYQ(ILIROK) = (POLYQ(ILDIAG)*DXIROW-POLYQ(ILOTHR)*DXKMN1)*& - FACTOR - ENDIF - END DO + FACTOR + ENDIF + END DO ! ! Check for convergence ! - ILDIAG = ILOC(IROW,IROW) - PESTT = POLYP(ILDIAG) - QESTT = POLYQ(ILDIAG) - IF (PESTT==0.0D00 .OR. QESTT==0.0D00) THEN - IF (IROW < MXORD) THEN - GO TO 4 - ELSE - PFFF(I,J) = PESTT - QFFF(I,J) = QESTT - ENDIF - ELSE - DPBP = ABS((PESTT - PESTL)/PESTT) - DQBQ = ABS((QESTT - QESTL)/QESTT) - IF (DQBQ0) WRITE (99, 301) ACCY, KOUNT, MFJ + IF (LDBPR(3) .AND. KOUNT>0) WRITE (99, 301) ACCY, KOUNT, MFJ ! ! Normalization ! - DNORM = RINTFF(J,J,0) - DNFAC = 1.0D00/SQRT(DNORM) - PFFF(:MFJ,J) = PFFF(:MFJ,J)*DNFAC - QFFF(:MFJ,J) = QFFF(:MFJ,J)*DNFAC + DNORM = RINTFF(J,J,0) + DNFAC = 1.0D00/SQRT(DNORM) + PFFF(:MFJ,J) = PFFF(:MFJ,J)*DNFAC + QFFF(:MFJ,J) = QFFF(:MFJ,J)*DNFAC ! - RETURN + RETURN ! 300 FORMAT(/,'INTRPQ: Grid of insufficient extent:'/,& ' Present grid has R(N) = ',1P,1D19.12,' Bohr radii'/,& - ' Require R(N) = ',1D19.12,' Bohr radii') + ' Require R(N) = ',1D19.12,' Bohr radii') 301 FORMAT(/,'INTRPQ: Interpolation procedure not converged to',1P,1D19.12,& - ' for ',1I3,' of ',1I3,' tabulation points') - RETURN - CONTAINS + ' for ',1I3,' of ',1I3,' tabulation points') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTRPQF + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTRPQF diff --git a/src/appl/rbiotransform90/intrpqf_I.f90 b/src/appl/rbiotransform90/intrpqf_I.f90 index 17b2df422..aba8ba1d3 100644 --- a/src/appl/rbiotransform90/intrpqf_I.f90 +++ b/src/appl/rbiotransform90/intrpqf_I.f90 @@ -1,16 +1,16 @@ - MODULE intrpqf_I + MODULE intrpqf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE intrpqf (PA, QA, MA, RA, J, DNORM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA - INTEGER, INTENT(IN) :: MA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE intrpqf (PA, QA, MA, RA, J, DNORM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA + INTEGER, INTENT(IN) :: MA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/intrpqi.f90 b/src/appl/rbiotransform90/intrpqi.f90 index d68a727eb..ea1119ea0 100644 --- a/src/appl/rbiotransform90/intrpqi.f90 +++ b/src/appl/rbiotransform90/intrpqi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) + SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! * ! This subprogram interpolates the arrays PA(1:MA), QA(1:MA), * ! tabulated on grid RA(1:MA) into the COMMON arrays PF(1:MF(J),J), * @@ -13,45 +13,45 @@ SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! Written by Farid A Parpia, at Oxford Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEBUG_C + USE DEBUG_C USE def_C, ONLY: accy USE grid_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rintii_I + USE rintii_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MA - INTEGER :: J - REAL(DOUBLE) , INTENT(OUT) :: DNORM + INTEGER, INTENT(IN) :: MA + INTEGER :: J + REAL(DOUBLE) , INTENT(OUT) :: DNORM REAL(DOUBLE) , DIMENSION(*), INTENT(IN) :: pa, qa, ra !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 13 + INTEGER, PARAMETER :: MXORD = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, MFJ, NRSTLO, KOUNT, IROW, K, NRSTHI, LLO, LHI, LOCNXT, & - ILIROK, ILDIAG, ILOTHR, MFJP1 - REAL(DOUBLE), DIMENSION(MXORD) :: X, DX - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ + ILIROK, ILDIAG, ILOTHR, MFJP1 + REAL(DOUBLE), DIMENSION(MXORD) :: X, DX + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ REAL(DOUBLE) :: RAMA, RN, XBAR, PESTL, QESTL, DIFF, DIFFT, DXKMN1, DXIROW& - , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC - LOGICAL :: SET - LOGICAL, DIMENSION(NNNP) :: USED + , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC + LOGICAL :: SET + LOGICAL, DIMENSION(NNNP) :: USED !----------------------------------------------- ! ! MXORD is the maximum order of the interpolation @@ -62,178 +62,178 @@ SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! ! Initialization ! - RAMA = RA(MA) - RN = R(N) + RAMA = RA(MA) + RN = R(N) ! ! This is always true in GRASP ! - PFII(1,J) = 0.0D00 - QFII(1,J) = 0.0D00 + PFII(1,J) = 0.0D00 + QFII(1,J) = 0.0D00 ! ! Checks ! - IF (RAMA > RN) THEN - WRITE (*, 300) RN, RAMA - STOP - ENDIF + IF (RAMA > RN) THEN + WRITE (*, 300) RN, RAMA + STOP + ENDIF ! ! Determine end of grid ! - I = N - 1 CONTINUE - I = I - 1 - IF (R(I) <= RAMA) THEN - MFJ = I - ELSE - GO TO 1 - ENDIF - MFII(J) = MFJ + I = N + 1 CONTINUE + I = I - 1 + IF (R(I) <= RAMA) THEN + MFJ = I + ELSE + GO TO 1 + ENDIF + MFII(J) = MFJ ! ! Overall initialization for interpolation ! - NRSTLO = 0 - KOUNT = 0 + NRSTLO = 0 + KOUNT = 0 ! ! Perform interpolation ! - DO I = 2, MFJ + DO I = 2, MFJ ! ! Initialization for interpolation ! - XBAR = R(I) - IROW = 0 - PESTL = 0.0D00 - QESTL = 0.0D00 + XBAR = R(I) + IROW = 0 + PESTL = 0.0D00 + QESTL = 0.0D00 ! ! Determine the nearest two grid points bounding the present ! grid point ! - 2 CONTINUE - K = NRSTLO + 1 - IF (RA(K) < XBAR) THEN - NRSTLO = K - GO TO 2 - ELSE - NRSTHI = K - ENDIF + 2 CONTINUE + K = NRSTLO + 1 + IF (RA(K) < XBAR) THEN + NRSTLO = K + GO TO 2 + ELSE + NRSTHI = K + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,MA) - USED(LLO:LHI) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,MA) + USED(LLO:LHI) = .FALSE. ! ! Determine next-nearest grid point ! - 4 CONTINUE - IROW = IROW + 1 - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,MA) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K)) CYCLE - IF (.NOT.SET) THEN - DIFF = RA(K) - XBAR - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = RA(K) - XBAR - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT) = .TRUE. - X(IROW) = RA(LOCNXT) - DX(IROW) = DIFF + 4 CONTINUE + IROW = IROW + 1 + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,MA) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K)) CYCLE + IF (.NOT.SET) THEN + DIFF = RA(K) - XBAR + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = RA(K) - XBAR + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT) = .TRUE. + X(IROW) = RA(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLYP(ILIROK) = PA(LOCNXT) - POLYQ(ILIROK) = QA(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) - DXKMN1 = DX(K-1) - DXIROW = DX(IROW) - FACTOR = 1.0D00/(X(IROW)-X(K-1)) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLYP(ILIROK) = PA(LOCNXT) + POLYQ(ILIROK) = QA(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) + DXKMN1 = DX(K-1) + DXIROW = DX(IROW) + FACTOR = 1.0D00/(X(IROW)-X(K-1)) POLYP(ILIROK) = (POLYP(ILDIAG)*DXIROW-POLYP(ILOTHR)*DXKMN1)*& - FACTOR + FACTOR POLYQ(ILIROK) = (POLYQ(ILDIAG)*DXIROW-POLYQ(ILOTHR)*DXKMN1)*& - FACTOR - ENDIF - END DO + FACTOR + ENDIF + END DO ! ! Check for convergence ! - ILDIAG = ILOC(IROW,IROW) - PESTT = POLYP(ILDIAG) - QESTT = POLYQ(ILDIAG) - IF (PESTT==0.0D00 .OR. QESTT==0.0D00) THEN - IF (IROW < MXORD) THEN - GO TO 4 - ELSE - PFII(I,J) = PESTT - QFII(I,J) = QESTT - ENDIF - ELSE - DPBP = ABS((PESTT - PESTL)/PESTT) - DQBQ = ABS((QESTT - QESTL)/QESTT) - IF (DQBQ0) WRITE (99, 301) ACCY, KOUNT, MFJ + IF (LDBPR(3) .AND. KOUNT>0) WRITE (99, 301) ACCY, KOUNT, MFJ ! ! Normalization ! - DNORM = RINTII(J,J,0) + DNORM = RINTII(J,J,0) !ww WRITE(92,*) 'DNORM',DNORM - DNFAC = 1.0D00/DSQRT(DNORM) - PFII(:MFJ,J) = PFII(:MFJ,J)*DNFAC - QFII(:MFJ,J) = QFII(:MFJ,J)*DNFAC + DNFAC = 1.0D00/DSQRT(DNORM) + PFII(:MFJ,J) = PFII(:MFJ,J)*DNFAC + QFII(:MFJ,J) = QFII(:MFJ,J)*DNFAC ! - RETURN + RETURN ! 300 FORMAT(/,'INTRPQ: Grid of insufficient extent:'/,& ' Present grid has R(N) = ',1P,1D19.12,' Bohr radii'/,& - ' Require R(N) = ',1D19.12,' Bohr radii') + ' Require R(N) = ',1D19.12,' Bohr radii') 301 FORMAT(/,'INTRPQ: Interpolation procedure not converged to',1P,1D19.12,& - ' for ',1I3,' of ',1I3,' tabulation points') - RETURN - CONTAINS + ' for ',1I3,' of ',1I3,' tabulation points') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTRPQI + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTRPQI diff --git a/src/appl/rbiotransform90/intrpqi_I.f90 b/src/appl/rbiotransform90/intrpqi_I.f90 index b929ed955..be14e19ec 100644 --- a/src/appl/rbiotransform90/intrpqi_I.f90 +++ b/src/appl/rbiotransform90/intrpqi_I.f90 @@ -1,16 +1,16 @@ - MODULE intrpqi_I + MODULE intrpqi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE intrpqi (PA, QA, MA, RA, J, DNORM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA - INTEGER, INTENT(IN) :: MA - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE intrpqi (PA, QA, MA, RA, J, DNORM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA + INTEGER, INTENT(IN) :: MA + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/invmat.f90 b/src/appl/rbiotransform90/invmat.f90 index 9697c8bbc..b2e18439e 100644 --- a/src/appl/rbiotransform90/invmat.f90 +++ b/src/appl/rbiotransform90/invmat.f90 @@ -4,7 +4,7 @@ ! I N V M A T ! ------------------------------------------------------------------ ! - SUBROUTINE INVMAT(A, B, MATDIM, NDIM) + SUBROUTINE INVMAT(A, B, MATDIM, NDIM) ! FIND INVERSE OF MATRIX A ! INPUT : ! A : MATRIX TO BE INVERTED @@ -15,53 +15,53 @@ SUBROUTINE INVMAT(A, B, MATDIM, NDIM) ! OUTPUT : A : INVERSE MATRIX ( ORIGINAL MATRIX THUS DESTROYED ) ! WARNINGS ARE ISSUED IN CASE OF CONVERGENCE PROBLEMS ) ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE bndinv_I - USE wrtmat_I + USE bndinv_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: MATDIM - INTEGER :: NDIM - REAL(DOUBLE) :: A(MATDIM,MATDIM) - REAL(DOUBLE) :: B(MATDIM,MATDIM) + INTEGER :: MATDIM + INTEGER :: NDIM + REAL(DOUBLE) :: A(MATDIM,MATDIM) + REAL(DOUBLE) :: B(MATDIM,MATDIM) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ITEST, NTEST - REAL(DOUBLE) :: DETERM, EPSIL + INTEGER :: ITEST, NTEST + REAL(DOUBLE) :: DETERM, EPSIL !----------------------------------------------- ! - ITEST = 0 - IF (NDIM == 1) THEN - IF (A(1,1) /= 0.0D0) THEN - A(1,1) = 1.0D0/A(1,1) - ELSE - ITEST = 1 - ENDIF - ELSE - DETERM = 0.0D0 - EPSIL = 0.0D0 - CALL BNDINV (A, B, NDIM, DETERM, EPSIL, ITEST, MATDIM) - ENDIF + ITEST = 0 + IF (NDIM == 1) THEN + IF (A(1,1) /= 0.0D0) THEN + A(1,1) = 1.0D0/A(1,1) + ELSE + ITEST = 1 + ENDIF + ELSE + DETERM = 0.0D0 + EPSIL = 0.0D0 + CALL BNDINV (A, B, NDIM, DETERM, EPSIL, ITEST, MATDIM) + ENDIF ! IF (ITEST /= 0) THEN - WRITE (6, '(A,I3)') ' INVERSION PROBLEM NUMBER..', ITEST + WRITE (6, '(A,I3)') ' INVERSION PROBLEM NUMBER..', ITEST STOP ENDIF - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' INVERTED MATRIX ' - CALL WRTMAT (A, NDIM, NDIM, MATDIM, MATDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' INVERTED MATRIX ' + CALL WRTMAT (A, NDIM, NDIM, MATDIM, MATDIM) + ENDIF ! - RETURN - END SUBROUTINE INVMAT + RETURN + END SUBROUTINE INVMAT diff --git a/src/appl/rbiotransform90/invmat_I.f90 b/src/appl/rbiotransform90/invmat_I.f90 index c7b71b85b..1e4f21b68 100644 --- a/src/appl/rbiotransform90/invmat_I.f90 +++ b/src/appl/rbiotransform90/invmat_I.f90 @@ -1,12 +1,12 @@ - MODULE invmat_I + MODULE invmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 - SUBROUTINE invmat (A, B, MATDIM, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(MATDIM,MATDIM), INTENT(INOUT) :: A - REAL(DOUBLE), DIMENSION(MATDIM,MATDIM) :: B - INTEGER, INTENT(IN) :: MATDIM - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 + SUBROUTINE invmat (A, B, MATDIM, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(MATDIM,MATDIM), INTENT(INOUT) :: A + REAL(DOUBLE), DIMENSION(MATDIM,MATDIM) :: B + INTEGER, INTENT(IN) :: MATDIM + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/kapdata.f90 b/src/appl/rbiotransform90/kapdata.f90 index 326092852..3c66ac7ae 100644 --- a/src/appl/rbiotransform90/kapdata.f90 +++ b/src/appl/rbiotransform90/kapdata.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) + SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! * ! This subroutine determines the number of kappa quantum numbers * ! KAMAX together with the number of orbitals of each kappa. * @@ -12,8 +12,8 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:44 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:44 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -38,168 +38,168 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NTESTG - INTEGER, INTENT(IN) :: NCORE1 - INTEGER, INTENT(IN) :: NCORE2 + INTEGER, INTENT(IN) :: NTESTG + INTEGER, INTENT(IN) :: NCORE1 + INTEGER, INTENT(IN) :: NCORE2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1 - INTEGER, DIMENSION(2*NNNW) :: ISORT - INTEGER :: NTESTL, NTEST, I, J, K, ITAL, NREF - LOGICAL :: KLAR + INTEGER :: J1 + INTEGER, DIMENSION(2*NNNW) :: ISORT + INTEGER :: NTESTL, NTEST, I, J, K, ITAL, NREF + LOGICAL :: KLAR !----------------------------------------------- ! ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - - ISORT(:2*NNNW) = 100 - - IKAPPA(:NLMAX) = 0 - NSHLII(:NLMAX) = 0 - NSHLFF(:NLMAX) = 0 - NINII(:NLMAX) = 0 - NINFF(:NLMAX) = 0 - - NAKINVII(:NNNW) = 0 - NAKINVFF(:NNNW) = 0 - - NSHLPII(:NLMAX,:NLMAX) = 0 - NSHLPFF(:NLMAX,:NLMAX) = 0 - - NSHLPPII(:NLMAX,:NNNW) = 0 - NSHLPPFF(:NLMAX,:NNNW) = 0 + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + + ISORT(:2*NNNW) = 100 + + IKAPPA(:NLMAX) = 0 + NSHLII(:NLMAX) = 0 + NSHLFF(:NLMAX) = 0 + NINII(:NLMAX) = 0 + NINFF(:NLMAX) = 0 + + NAKINVII(:NNNW) = 0 + NAKINVFF(:NNNW) = 0 + + NSHLPII(:NLMAX,:NLMAX) = 0 + NSHLPFF(:NLMAX,:NLMAX) = 0 + + NSHLPPII(:NLMAX,:NNNW) = 0 + NSHLPPFF(:NLMAX,:NNNW) = 0 ! ! Sort the kappa quantum numbers ! - DO K = 1, NWII + NWFF - IF (K <= NWII) THEN - ITAL = NAKII(K) - ELSE - ITAL = NAKFF(K-NWII) - ENDIF - I = K - 1 - KLAR = .FALSE. - 12 CONTINUE - IF (I>0 .AND. .NOT.KLAR) THEN - IF (ITAL <= ISORT(I)) THEN - ISORT(I+1) = ISORT(I) - I = I - 1 - ELSE - KLAR = .TRUE. - ENDIF - GO TO 12 - ENDIF - ISORT(I+1) = ITAL - END DO + DO K = 1, NWII + NWFF + IF (K <= NWII) THEN + ITAL = NAKII(K) + ELSE + ITAL = NAKFF(K-NWII) + ENDIF + I = K - 1 + KLAR = .FALSE. + 12 CONTINUE + IF (I>0 .AND. .NOT.KLAR) THEN + IF (ITAL <= ISORT(I)) THEN + ISORT(I+1) = ISORT(I) + I = I - 1 + ELSE + KLAR = .TRUE. + ENDIF + GO TO 12 + ENDIF + ISORT(I+1) = ITAL + END DO ! ! Determine the unique set of kappa IKAPPA ! - KAMAX = 1 - IKAPPA(1) = ISORT(1) - DO K = 1, 2*NNNW - 1 - IF (ISORT(K)==ISORT(K+1) .OR. ISORT(K+1)>=100) CYCLE - KAMAX = KAMAX + 1 - IKAPPA(KAMAX) = ISORT(K+1) - END DO + KAMAX = 1 + IKAPPA(1) = ISORT(1) + DO K = 1, 2*NNNW - 1 + IF (ISORT(K)==ISORT(K+1) .OR. ISORT(K+1)>=100) CYCLE + KAMAX = KAMAX + 1 + IKAPPA(KAMAX) = ISORT(K+1) + END DO ! ! Make a connection between each kappa and a number in the ! range [1,KAMAX] as to know on which file to dump the data ! Determine the number of shells NSHLII for each I in the ! range [1,KAMAX] ! - IF (NTEST >= 10) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering kapdata' - WRITE (*, *) '******************' - WRITE (*, *) - WRITE (*, *) 'There are', NWII, 'orbitals in the initial state' - WRITE (*, *) 'with the following n and kappa quantum numbers' - ENDIF - - DO J = 1, NWII + IF (NTEST >= 10) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering kapdata' + WRITE (*, *) '******************' + WRITE (*, *) + WRITE (*, *) 'There are', NWII, 'orbitals in the initial state' + WRITE (*, *) 'with the following n and kappa quantum numbers' + ENDIF + + DO J = 1, NWII IF (NTEST >= 10) WRITE (*, *) 'orbital number', J, 'n and kappa', NPII& - (J), NAKII(J) - IF (J <= NCORE1) THEN - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKII(J)) CYCLE - NAKINVII(J) = I - NINII(I) = NINII(I) + 1 - NSHLII(I) = NSHLII(I) + 1 - NSHLPII(I,NSHLII(I)) = J - NSHLPPII(I,J) = NSHLII(I) - END DO - ELSE - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKII(J)) CYCLE - NAKINVII(J) = I - NSHLII(I) = NSHLII(I) + 1 - NSHLPII(I,NSHLII(I)) = J - NSHLPPII(I,J) = NSHLII(I) - END DO - ENDIF - END DO - - IF (NTEST >= 10) THEN - WRITE (*, *) 'There are', NWFF, 'orbitals in the final state' - WRITE (*, *) 'with the following n and kappa quantum numbers' - ENDIF - DO J = 1, NWFF + (J), NAKII(J) + IF (J <= NCORE1) THEN + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKII(J)) CYCLE + NAKINVII(J) = I + NINII(I) = NINII(I) + 1 + NSHLII(I) = NSHLII(I) + 1 + NSHLPII(I,NSHLII(I)) = J + NSHLPPII(I,J) = NSHLII(I) + END DO + ELSE + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKII(J)) CYCLE + NAKINVII(J) = I + NSHLII(I) = NSHLII(I) + 1 + NSHLPII(I,NSHLII(I)) = J + NSHLPPII(I,J) = NSHLII(I) + END DO + ENDIF + END DO + + IF (NTEST >= 10) THEN + WRITE (*, *) 'There are', NWFF, 'orbitals in the final state' + WRITE (*, *) 'with the following n and kappa quantum numbers' + ENDIF + DO J = 1, NWFF IF (NTEST >= 10) WRITE (*, *) 'orbital number', J, 'n and kappa=', & - NPFF(J), NAKFF(J) - IF (J <= NCORE2) THEN - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKFF(J)) CYCLE - NAKINVFF(J) = I - NINFF(I) = NINFF(I) + 1 - NSHLFF(I) = NSHLFF(I) + 1 - NSHLPFF(I,NSHLFF(I)) = J - NSHLPPFF(I,J) = NSHLFF(I) - END DO - ELSE - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKFF(J)) CYCLE - NAKINVFF(J) = I - NSHLFF(I) = NSHLFF(I) + 1 - NSHLPFF(I,NSHLFF(I)) = J - NSHLPPFF(I,J) = NSHLFF(I) - END DO - ENDIF - END DO - - IF (NTEST >= 10) THEN - WRITE (*, *) 'Total number of different kappa', KAMAX - DO I = 1, KAMAX - WRITE (*, *) 'L=', I, 'corresponds to kappa=', IKAPPA(I) - WRITE (*, *) 'nr of init. orb. with this kappa=', NSHLII(I) - WRITE (*, *) 'nr of final. orb. with this kappa=', NSHLFF(I) - END DO - DO I = 1, KAMAX - WRITE (*, *) 'Position in initial state list' - DO J = 1, NSHLII(I) - WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPII(I,J) - END DO - WRITE (*, *) 'Position in final state list' - DO J = 1, NSHLFF(I) - WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPFF(I,J) - END DO - WRITE (*, *) 'Relative positions for initial state orbitals' - DO J = 1, NWII - IF (NSHLPPII(I,J) == 0) CYCLE + NPFF(J), NAKFF(J) + IF (J <= NCORE2) THEN + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKFF(J)) CYCLE + NAKINVFF(J) = I + NINFF(I) = NINFF(I) + 1 + NSHLFF(I) = NSHLFF(I) + 1 + NSHLPFF(I,NSHLFF(I)) = J + NSHLPPFF(I,J) = NSHLFF(I) + END DO + ELSE + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKFF(J)) CYCLE + NAKINVFF(J) = I + NSHLFF(I) = NSHLFF(I) + 1 + NSHLPFF(I,NSHLFF(I)) = J + NSHLPPFF(I,J) = NSHLFF(I) + END DO + ENDIF + END DO + + IF (NTEST >= 10) THEN + WRITE (*, *) 'Total number of different kappa', KAMAX + DO I = 1, KAMAX + WRITE (*, *) 'L=', I, 'corresponds to kappa=', IKAPPA(I) + WRITE (*, *) 'nr of init. orb. with this kappa=', NSHLII(I) + WRITE (*, *) 'nr of final. orb. with this kappa=', NSHLFF(I) + END DO + DO I = 1, KAMAX + WRITE (*, *) 'Position in initial state list' + DO J = 1, NSHLII(I) + WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPII(I,J) + END DO + WRITE (*, *) 'Position in final state list' + DO J = 1, NSHLFF(I) + WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPFF(I,J) + END DO + WRITE (*, *) 'Relative positions for initial state orbitals' + DO J = 1, NWII + IF (NSHLPPII(I,J) == 0) CYCLE WRITE (*, *) 'Orbital', J, 'is nr', NSHLPPII(I,J), 'with kappa'& - , IKAPPA(I) - END DO - WRITE (*, *) 'Relative positions for final state orbitals' - DO J = 1, NWFF - IF (NSHLPPFF(I,J) == 0) CYCLE + , IKAPPA(I) + END DO + WRITE (*, *) 'Relative positions for final state orbitals' + DO J = 1, NWFF + IF (NSHLPPFF(I,J) == 0) CYCLE WRITE (*, *) 'Orbital', J, 'is nr', NSHLPPFF(I,J), 'with kappa'& - , IKAPPA(I) - END DO - END DO - - ENDIF + , IKAPPA(I) + END DO + END DO + + ENDIF ! ! Check if the orbital ordering is normal or reversed. ! @@ -211,70 +211,70 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! ! NPII(NSHLPII(I,1)) > NPII(NSHLPII(I,2)) > ... > NPII(NSHLPII(I,NSHLII(I)) ! - NORDII = 0 - DO I = 1, KAMAX - NREF = 0 - DO J = 1 + NINII(I), NSHLII(I) - IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 1 - NREF = NPII(NSHLPII(I,J)) - END DO - END DO - - NORDFF = 0 - DO I = 1, KAMAX - NREF = 0 - DO J = 1 + NINFF(I), NSHLFF(I) - IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 1 - NREF = NPFF(NSHLPFF(I,J)) - END DO - END DO - - IF (NORDII /= NORDFF) THEN - WRITE (*, *) ' Orbital order of the initial and final states' - WRITE (*, *) ' should be the same. STOP' - STOP - ENDIF + NORDII = 0 + DO I = 1, KAMAX + NREF = 0 + DO J = 1 + NINII(I), NSHLII(I) + IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 1 + NREF = NPII(NSHLPII(I,J)) + END DO + END DO + + NORDFF = 0 + DO I = 1, KAMAX + NREF = 0 + DO J = 1 + NINFF(I), NSHLFF(I) + IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 1 + NREF = NPFF(NSHLPFF(I,J)) + END DO + END DO + + IF (NORDII /= NORDFF) THEN + WRITE (*, *) ' Orbital order of the initial and final states' + WRITE (*, *) ' should be the same. STOP' + STOP + ENDIF ! ! If not normal order check if reversed order ! - IF (NORDII == 1) THEN - DO I = 1, KAMAX - NREF = 0 - DO J = NSHLII(I), 1 + NINII(I), -1 - IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 2 - NREF = NPII(NSHLPII(I,J)) - END DO - END DO - - DO I = 1, KAMAX - NREF = 0 - DO J = NSHLFF(I), 1 + NINFF(I), -1 - IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 2 - NREF = NPFF(NSHLPFF(I,J)) - END DO - END DO - ENDIF - - IF (NORDII==2 .OR. NORDFF==2) THEN - WRITE (*, *) ' The orbital order is neither normal or reversed' - WRITE (*, *) ' STOP' - STOP - ENDIF - + IF (NORDII == 1) THEN + DO I = 1, KAMAX + NREF = 0 + DO J = NSHLII(I), 1 + NINII(I), -1 + IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 2 + NREF = NPII(NSHLPII(I,J)) + END DO + END DO + + DO I = 1, KAMAX + NREF = 0 + DO J = NSHLFF(I), 1 + NINFF(I), -1 + IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 2 + NREF = NPFF(NSHLPFF(I,J)) + END DO + END DO + ENDIF + + IF (NORDII==2 .OR. NORDFF==2) THEN + WRITE (*, *) ' The orbital order is neither normal or reversed' + WRITE (*, *) ' STOP' + STOP + ENDIF + !w write(*,*) 'Give nordii' !w read(*,*) nordii !w nordff = nordii - - IF (NORDII == 0) THEN - WRITE (*, *) ' Normal orbital ordering' - ELSE - WRITE (*, *) ' Reverse orbital ordering' - ENDIF - - WRITE (*, *) '*****************' - WRITE (*, *) ' Leaving kapdata' - WRITE (*, *) '*****************' - WRITE (*, *) - - RETURN - END SUBROUTINE KAPDATA + + IF (NORDII == 0) THEN + WRITE (*, *) ' Normal orbital ordering' + ELSE + WRITE (*, *) ' Reverse orbital ordering' + ENDIF + + WRITE (*, *) '*****************' + WRITE (*, *) ' Leaving kapdata' + WRITE (*, *) '*****************' + WRITE (*, *) + + RETURN + END SUBROUTINE KAPDATA diff --git a/src/appl/rbiotransform90/kapdata_I.f90 b/src/appl/rbiotransform90/kapdata_I.f90 index db7eb181c..5135e26ad 100644 --- a/src/appl/rbiotransform90/kapdata_I.f90 +++ b/src/appl/rbiotransform90/kapdata_I.f90 @@ -1,12 +1,12 @@ - MODULE kapdata_I + MODULE kapdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE kapdata (NTESTG, NCORE1, NCORE2) - INTEGER, INTENT(IN) :: NTESTG - INTEGER, INTENT(IN) :: NCORE1 - INTEGER, INTENT(IN) :: NCORE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE kapdata (NTESTG, NCORE1, NCORE2) + INTEGER, INTENT(IN) :: NTESTG + INTEGER, INTENT(IN) :: NCORE1 + INTEGER, INTENT(IN) :: NCORE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/lodcslBio.f90 b/src/appl/rbiotransform90/lodcslBio.f90 index e7d3d4e96..b871bdd18 100644 --- a/src/appl/rbiotransform90/lodcslBio.f90 +++ b/src/appl/rbiotransform90/lodcslBio.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSLBio(NCORE,IGG) + SUBROUTINE LODCSLBio(NCORE,IGG) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -15,115 +15,115 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE ORB_C + USE DEBUG_C + USE DEF_C + USE ORB_C USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C USE BLK_C, only: NBLOCK,NCFBLK USE memory_man !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER, INTENT(IN) :: IGG - INTEGER, INTENT(OUT) :: NCORE + INTEGER, INTENT(OUT) :: NCORE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: IOCC - INTEGER , DIMENSION(NW2) :: IQSUB - INTEGER , DIMENSION(NNNW) :: JX + INTEGER , DIMENSION(NNNW) :: IOCC + INTEGER , DIMENSION(NW2) :: IQSUB + INTEGER , DIMENSION(NNNW) :: JX INTEGER :: I INTEGER :: NCORP1, NPEEL, NPEEL2, J, NPJ, NAKJ, LENTH, NCFD, NREC & , IOS, IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN & , NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU & - , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECL - CHARACTER(LEN=256) :: RECORD + , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECL + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! ! Entry message ! - WRITE (6, *) 'Loading Configuration Symmetry List File ...' + WRITE (6, *) 'Loading Configuration Symmetry List File ...' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (21, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (21, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (21, *) - CALL PRSRSL (21, 2) - NPEEL = NW - NCORE - NPEEL2 = NPEEL*2 + READ (21, *) + CALL PRSRSL (21, 2) + NPEEL = NW - NCORE + NPEEL2 = NPEEL*2 ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'LODCSL: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) 'There are '//RECORD(1:LENTH)// & - ' relativistic subshells;' - ELSE - WRITE (6, *) 'There is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) 'There is 1 relativistic subshell;' + ENDIF ! ! Initial allocation for arrays with a dimension dependent ! on the number of CSFs; the initial allocation must be ! greater than 1 ! IF(IGG == 1) THEN - NCFD = 1000 + NCFD = 1000 CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSL') CALL ALLOC (JQSA, NNNW,3,NCFD, 'JQSA', 'LODCSL') CALL ALLOC (JCUPA,NNNW, NCFD, 'JCUPA', 'LODCSL') @@ -136,7 +136,7 @@ SUBROUTINE LODCSLBio(NCORE,IGG) CALL DALLOC (IQA, 'IQA', 'LODCSL') CALL DALLOC (JQSA, 'JQSA', 'LODCSL') CALL DALLOC (JCUPA, 'JCUPA', 'LODCSL') - NCFD = 1000 + NCFD = 1000 CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSL') CALL ALLOC (JQSA, NNNW,3,NCFD, 'JQSA', 'LODCSL') CALL ALLOC (JCUPA,NNNW, NCFD, 'JCUPA', 'LODCSL') @@ -145,12 +145,12 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! ! Skip the header for the list of CSFs ! - READ (21, *) + READ (21, *) ! ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -182,65 +182,65 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! These conventions have been chosen so as to render the CSF ! specifications easily interpreted by the user ! - NCF = 0 - NBLOCK = 0 - 3 CONTINUE - NCF = NCF + 1 + NCF = 0 + NBLOCK = 0 + 3 CONTINUE + NCF = NCF + 1 ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** !blk* ! To skip the border line added to mark the end of a block ! - IF (RECORD(1:2) == ' *') THEN - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -1 - READ (21, '(A)', IOSTAT=IOS) RECORD - ENDIF + IF (RECORD(1:2) == ' *') THEN + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF -1 + READ (21, '(A)', IOSTAT=IOS) RECORD + ENDIF !********************************************************************** - - IF (IOS == 0) THEN + + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting subshell quantum', & - ' number specification;' - GO TO 26 - ENDIF - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + ' number specification;' + GO TO 26 + ENDIF + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Allocate additional storage if necessary ! !CFF It is possible that this should be moved to "3 Continue" ! where NCF is incremented - IF (NCF > NCFD) THEN - NEWSIZ = NCFD + NCFD/2 + IF (NCF > NCFD) THEN + NEWSIZ = NCFD + NCFD/2 CALL RALLOC (IQA, NNNW, NEWSIZ, 'IQA', 'LODCSL') CALL RALLOC (JQSA, NNNW,3,NEWSIZ, 'JQSA', 'LODCSL') CALL RALLOC (JCUPA,NNNW, NEWSIZ, 'JCUPA', 'LODCSL') - NCFD = NEWSIZ - ENDIF + NCFD = NEWSIZ + ENDIF ! ! Zero out the arrays that store packed integers ! @@ -255,329 +255,329 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) 'LODCSL: Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell quantum', & - ' numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + ' numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) 'LODCSL: Subshell quantum numbers ', & 'specified incorrectly for '//RECORD(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) & 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I),& - ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) 'LODCSL: Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) 'LODCSL: Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! - IF (NCF > 1) THEN - DO J = 1, NCF - 1 - DO I = NCORP1, NW - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (NCF > 1) THEN + DO J = 1, NCF - 1 + DO I = NCORP1, NW + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs; eliminating this', ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) + ' in all CSFs; eliminating this', ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL ! ! All done; report ! - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' - WRITE (6, *) ' ... load complete;' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' + WRITE (6, *) ' ... load complete;' ! ! Debug printout ! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF - - - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -! - RETURN -! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF + + + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF +! + RETURN +! + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 READ (21,'(A)',ERR = 29,END = 29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (ISTDE, *) RECORD(1:LENTH) - END DO - 29 CLOSE(21) - STOP + LENTH = LEN_TRIM(RECORD) + WRITE (ISTDE, *) RECORD(1:LENTH) + END DO + 29 CLOSE(21) + STOP ! END SUBROUTINE LODCSLBio diff --git a/src/appl/rbiotransform90/lodcslBio_I.f90 b/src/appl/rbiotransform90/lodcslBio_I.f90 index d9f71b7ab..663c82361 100644 --- a/src/appl/rbiotransform90/lodcslBio_I.f90 +++ b/src/appl/rbiotransform90/lodcslBio_I.f90 @@ -1,11 +1,11 @@ - MODULE lodcslbio_I + MODULE lodcslbio_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcslbio (NCORE,IGG) + SUBROUTINE lodcslbio (NCORE,IGG) INTEGER, INTENT(IN) :: IGG - INTEGER, INTENT(OUT) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(OUT) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/lodrwff.f90 b/src/appl/rbiotransform90/lodrwff.f90 index 56065de56..00673c48c 100644 --- a/src/appl/rbiotransform90/lodrwff.f90 +++ b/src/appl/rbiotransform90/lodrwff.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFF(NAME, NTESTG) + SUBROUTINE LODRWFF(NAME, NTESTG) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -10,18 +10,18 @@ SUBROUTINE LODRWFF(NAME, NTESTG) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE memory_man USE biorb_C USE def_C, ONLY: z, c - USE DEBUG_C + USE DEBUG_C USE grid_C USE npar_C USE sbdat_C, ONLY: kamax, nshlff, nshlpff @@ -29,163 +29,163 @@ SUBROUTINE LODRWFF(NAME, NTESTG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE intrpqf_I + USE intrpqf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NTESTG - CHARACTER , INTENT(IN) :: NAME*24 + INTEGER , INTENT(IN) :: NTESTG + CHARACTER , INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: NAK, NP + INTEGER , DIMENSION(NNNW) :: NAK, NP INTEGER :: NTESTL, NTEST, J, K, I, NWIN, IOS, NPY, NAKY, MY, JJ, KK, JJJ& - , KKK, IERR - REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA - REAL(DOUBLE) :: CON, FKK, EY, DNORM, PZY + , KKK, IERR + REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA + REAL(DOUBLE) :: CON, FKK, EY, DNORM, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER , DIMENSION(NNNW) :: NH*2 - CHARACTER :: G92RWF*6 + CHARACTER , DIMENSION(NNNW) :: NH*2 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the final state ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - NTEST = 0 - + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + NTEST = 0 + ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for final state...' + WRITE (6, *) 'Loading Radial WaveFunction File for final state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21,FILE=NAME(1:J-1)//'.w',FORM='UNFORMATTED', & - STATUS='OLD',POSITION='asis') + STATUS='OLD',POSITION='asis') ! ! Save NAK, NP and NH ! - NAK(:NWFF) = NAKFF(:NWFF) - NP(:NWFF) = NPFF(:NWFF) - NH(:NWFF) = NHFF(:NWFF) + NAK(:NWFF) = NAKFF(:NWFF) + NP(:NWFF) = NPFF(:NWFF) + NH(:NWFF) = NHFF(:NWFF) ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFFF, NNNP,NWFF, 'PFFF', 'LODRWFF') - CALL ALLOC (QFFF, NNNP,NWFF, 'QFFF', 'LODRWF') + CALL ALLOC (PFFF, NNNP,NWFF, 'PFFF', 'LODRWFF') + CALL ALLOC (QFFF, NNNP,NWFF, 'QFFF', 'LODRWF') ! - CON = Z/C - CON = CON*CON + CON = Z/C + CON = CON*CON ! - DO J = 1, NWFF - PFFF(:NNNP,J) = 0.0D00 - QFFF(:NNNP,J) = 0.0D00 + DO J = 1, NWFF + PFFF(:NNNP,J) = 0.0D00 + QFFF(:NNNP,J) = 0.0D00 ! - K = ABS(NAK(J)) - IF (NPARM /= 0) CYCLE - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF + K = ABS(NAK(J)) + IF (NPARM /= 0) CYCLE + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF ! - END DO + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (21, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(21) - ENDIF - - IF (NTEST >= 100) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering lodrwff' - WRITE (*, *) '******************' - ENDIF - - 3 CONTINUE - READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY - IF (IOS == 0) THEN - CALL ALLOC (PA, MY, 'PA', 'LODRWFFF') - CALL ALLOC (QA, MY, 'QA', 'LODRWFFF') - CALL ALLOC (RA, MY, 'RA', 'LODRWFFF') - READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (21) (RA(I),I=1,MY) + NWIN = 0 + READ (21, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(21) + ENDIF + + IF (NTEST >= 100) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering lodrwff' + WRITE (*, *) '******************' + ENDIF + + 3 CONTINUE + READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY + IF (IOS == 0) THEN + CALL ALLOC (PA, MY, 'PA', 'LODRWFFF') + CALL ALLOC (QA, MY, 'QA', 'LODRWFFF') + CALL ALLOC (RA, MY, 'RA', 'LODRWFFF') + READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (21) (RA(I),I=1,MY) ! ! Orbital order as defined in kapdata ! - JJ = 0 - DO K = 1, KAMAX - IF (K > 1) JJ = NSHLFF(K-1) + JJ - DO J = 1, NSHLFF(K) - KK = NSHLPFF(K,J) - IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE - JJJ = JJ + J - PZFF(JJJ) = PZY - EFF(JJJ) = EY - NAKFF(JJJ) = NAK(KK) - NPFF(JJJ) = NP(KK) - NHFF(JJJ) = NH(KK) - GAMAFF(JJJ) = GAMA(KK) - CALL INTRPQF (PA, QA, MY, RA, JJJ, DNORM) + JJ = 0 + DO K = 1, KAMAX + IF (K > 1) JJ = NSHLFF(K-1) + JJ + DO J = 1, NSHLFF(K) + KK = NSHLPFF(K,J) + IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE + JJJ = JJ + J + PZFF(JJJ) = PZY + EFF(JJJ) = EY + NAKFF(JJJ) = NAK(KK) + NPFF(JJJ) = NP(KK) + NHFF(JJJ) = NH(KK) + GAMAFF(JJJ) = GAMA(KK) + CALL INTRPQF (PA, QA, MY, RA, JJJ, DNORM) IF (NTEST >= 100) WRITE (*, 301) NPFF(JJJ), NHFF(JJJ), EFF(JJJ)& - , DNORM - IF (NTEST > 1000) THEN - WRITE (*, *) 'PF QF RA' - DO KKK = 1, MFFF(JJJ) - WRITE (*, *) PFFF(KKK,JJJ), QFFF(KKK,JJJ), RA(KKK) - END DO - ENDIF - NWIN = NWIN + 1 - END DO - END DO - CALL DALLOC (PA, 'PA', 'LODRWFF') - CALL DALLOC (QA, 'QA', 'LODRWFF') - CALL DALLOC (RA, 'RA', 'LODRWFF') + , DNORM + IF (NTEST > 1000) THEN + WRITE (*, *) 'PF QF RA' + DO KKK = 1, MFFF(JJJ) + WRITE (*, *) PFFF(KKK,JJJ), QFFF(KKK,JJJ), RA(KKK) + END DO + ENDIF + NWIN = NWIN + 1 + END DO + END DO + CALL DALLOC (PA, 'PA', 'LODRWFF') + CALL DALLOC (QA, 'QA', 'LODRWFF') + CALL DALLOC (RA, 'RA', 'LODRWFF') - GO TO 3 - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + GO TO 3 + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWFF) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - IERR = 1 - GO TO 5 - ENDIF -! - WRITE (6, *) ' ... load complete;' -! - 5 CONTINUE - CLOSE(21) - IF (NTEST >= 100) THEN - WRITE (*, *) 'Sorted order should be the same as from kapdat' - DO J = 1, NWFF - WRITE (*, 301) NPFF(J), NHFF(J), EFF(J), DNORM - END DO - WRITE (*, *) - WRITE (*, *) '*****************' - WRITE (*, *) ' Leaving lodrwff' - WRITE (*, *) '*****************' - ENDIF - - RETURN -! - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN -! - END SUBROUTINE LODRWFF + IF (NWIN < NWFF) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + IERR = 1 + GO TO 5 + ENDIF +! + WRITE (6, *) ' ... load complete;' +! + 5 CONTINUE + CLOSE(21) + IF (NTEST >= 100) THEN + WRITE (*, *) 'Sorted order should be the same as from kapdat' + DO J = 1, NWFF + WRITE (*, 301) NPFF(J), NHFF(J), EFF(J), DNORM + END DO + WRITE (*, *) + WRITE (*, *) '*****************' + WRITE (*, *) ' Leaving lodrwff' + WRITE (*, *) '*****************' + ENDIF + + RETURN +! + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN +! + END SUBROUTINE LODRWFF diff --git a/src/appl/rbiotransform90/lodrwff_I.f90 b/src/appl/rbiotransform90/lodrwff_I.f90 index e07cf38a2..b5b2f3c33 100644 --- a/src/appl/rbiotransform90/lodrwff_I.f90 +++ b/src/appl/rbiotransform90/lodrwff_I.f90 @@ -1,11 +1,11 @@ - MODULE lodrwff_I + MODULE lodrwff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwff (NAME, NTESTG) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwff (NAME, NTESTG) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/lodrwfi.f90 b/src/appl/rbiotransform90/lodrwfi.f90 index 61a1fa59e..f47cb6544 100644 --- a/src/appl/rbiotransform90/lodrwfi.f90 +++ b/src/appl/rbiotransform90/lodrwfi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFI(NAME, NTESTG) + SUBROUTINE LODRWFI(NAME, NTESTG) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -10,13 +10,13 @@ SUBROUTINE LODRWFI(NAME, NTESTG) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE memory_man USE biorb_C @@ -29,49 +29,49 @@ SUBROUTINE LODRWFI(NAME, NTESTG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE intrpqi_I + USE intrpqi_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NTESTG - CHARACTER , INTENT(IN) :: NAME*24 + INTEGER , INTENT(IN) :: NTESTG + CHARACTER , INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: NAK, NP + INTEGER , DIMENSION(NNNW) :: NAK, NP INTEGER :: NTESTL, NTEST, J, K, I, NWIN, IOS, NPY, NAKY, MY, JJ, KK, JJJ& - , KKK, IERR - REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA - REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM + , KKK, IERR + REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA + REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER , DIMENSION(NNNW) :: NH*2 - CHARACTER :: G92RWF*6 + CHARACTER , DIMENSION(NNNW) :: NH*2 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the initial state ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - NTEST = 0 - + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + NTEST = 0 + ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' + WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21, FILE=NAME(1:J-1)//'.w', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Save NAK, NP and NH ! - NAK(:NWII) = NAKII(:NWII) - NP(:NWII) = NPII(:NWII) - NH(:NWII) = NHII(:NWII) + NAK(:NWII) = NAKII(:NWII) + NP(:NWII) = NPII(:NWII) + NH(:NWII) = NHII(:NWII) ! ! Allocate storage to orbital arrays ! @@ -79,113 +79,113 @@ SUBROUTINE LODRWFI(NAME, NTESTG) CALL ALLOC (QFII, NNNP,NWII, 'QFII', 'LODRWII') ! - CON = Z/C - CON = CON*CON + CON = Z/C + CON = CON*CON ! - DO J = 1, NWII - PFII(:NNNP,J) = 0.0D00 - QFII(:NNNP,J) = 0.0D00 + DO J = 1, NWII + PFII(:NNNP,J) = 0.0D00 + QFII(:NNNP,J) = 0.0D00 ! - K = ABS(NAK(J)) - IF (NPARM /= 0) CYCLE - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF + K = ABS(NAK(J)) + IF (NPARM /= 0) CYCLE + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF ! - END DO + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (21, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(21) - ENDIF - - IF (NTEST >= 100) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering lodrwfi' - WRITE (*, *) '******************' - ENDIF - - 3 CONTINUE - READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY - IF (IOS == 0) THEN + NWIN = 0 + READ (21, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(21) + ENDIF + + IF (NTEST >= 100) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering lodrwfi' + WRITE (*, *) '******************' + ENDIF + + 3 CONTINUE + READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY + IF (IOS == 0) THEN CALL ALLOC (PA, MY, 'PA', 'LODRWFII') CALL ALLOC (QA, MY, 'QA', 'LODRWFII') CALL ALLOC (RA, MY, 'RA', 'LODRWFII') - READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (21) (RA(I),I=1,MY) + READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (21) (RA(I),I=1,MY) ! ! Orbital order as defined in kapdata ! - JJ = 0 - DO K = 1, KAMAX - IF (K > 1) JJ = NSHLII(K-1) + JJ - DO J = 1, NSHLII(K) - KK = NSHLPII(K,J) - IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE - JJJ = JJ + J - PZII(JJJ) = PZY - EII(JJJ) = EY - NAKII(JJJ) = NAK(KK) - NPII(JJJ) = NP(KK) - NHII(JJJ) = NH(KK) - GAMAII(JJJ) = GAMA(KK) - CALL INTRPQI (PA, QA, MY, RA, JJJ, DNORM) + JJ = 0 + DO K = 1, KAMAX + IF (K > 1) JJ = NSHLII(K-1) + JJ + DO J = 1, NSHLII(K) + KK = NSHLPII(K,J) + IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE + JJJ = JJ + J + PZII(JJJ) = PZY + EII(JJJ) = EY + NAKII(JJJ) = NAK(KK) + NPII(JJJ) = NP(KK) + NHII(JJJ) = NH(KK) + GAMAII(JJJ) = GAMA(KK) + CALL INTRPQI (PA, QA, MY, RA, JJJ, DNORM) IF (NTEST >= 100) WRITE (*, 301) NPII(JJJ), NHII(JJJ), EII(JJJ)& - , DNORM - IF (NTEST > 1000) THEN - WRITE (*, *) 'PF QF RA' - DO KKK = 1, MFII(JJJ) - WRITE (*, *) PFII(KKK,JJJ), QFII(KKK,JJJ), RA(KKK) - END DO - ENDIF - NWIN = NWIN + 1 - END DO - END DO + , DNORM + IF (NTEST > 1000) THEN + WRITE (*, *) 'PF QF RA' + DO KKK = 1, MFII(JJJ) + WRITE (*, *) PFII(KKK,JJJ), QFII(KKK,JJJ), RA(KKK) + END DO + ENDIF + NWIN = NWIN + 1 + END DO + END DO CALL DALLOC (PA, 'PA', 'LODRWII') CALL DALLOC (QA, 'QA', 'LODRWII') CALL DALLOC (RA, 'RA', 'LODRWII') - GO TO 3 - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + GO TO 3 + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWII) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - IERR = 1 - GO TO 5 - ENDIF -! - WRITE (6, *) ' ... load complete;' -! - 5 CONTINUE - CLOSE(21) - IF (NTEST >= 100) THEN - WRITE (*, *) 'Sorted order should be the same as from kapdat' - DO J = 1, NWII - WRITE (*, 301) NPII(J), NHII(J), EII(J), DNORM - END DO - WRITE (*, *) - WRITE (*, *) '*****************' - WRITE (*, *) ' Leaving lodrwfi' - WRITE (*, *) '*****************' - ENDIF - - RETURN -! - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN -! - END SUBROUTINE LODRWFI + IF (NWIN < NWII) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + IERR = 1 + GO TO 5 + ENDIF +! + WRITE (6, *) ' ... load complete;' +! + 5 CONTINUE + CLOSE(21) + IF (NTEST >= 100) THEN + WRITE (*, *) 'Sorted order should be the same as from kapdat' + DO J = 1, NWII + WRITE (*, 301) NPII(J), NHII(J), EII(J), DNORM + END DO + WRITE (*, *) + WRITE (*, *) '*****************' + WRITE (*, *) ' Leaving lodrwfi' + WRITE (*, *) '*****************' + ENDIF + + RETURN +! + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN +! + END SUBROUTINE LODRWFI diff --git a/src/appl/rbiotransform90/lodrwfi_I.f90 b/src/appl/rbiotransform90/lodrwfi_I.f90 index 98c8b140c..ffd3fb9a2 100644 --- a/src/appl/rbiotransform90/lodrwfi_I.f90 +++ b/src/appl/rbiotransform90/lodrwfi_I.f90 @@ -1,11 +1,11 @@ - MODULE lodrwfi_I + MODULE lodrwfi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwfi (NAME, NTESTG) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwfi (NAME, NTESTG) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/lulu.f90 b/src/appl/rbiotransform90/lulu.f90 index 8ca38f565..88df711c5 100644 --- a/src/appl/rbiotransform90/lulu.f90 +++ b/src/appl/rbiotransform90/lulu.f90 @@ -4,7 +4,7 @@ ! L U L U ! ------------------------------------------------------------------ ! - SUBROUTINE LULU(A, L, U, NDIM) + SUBROUTINE LULU(A, L, U, NDIM) ! ! LU DECOMPOSITION OF MATRIX A ! @@ -38,55 +38,55 @@ SUBROUTINE LULU(A, L, U, NDIM) ! JEPPE OLSEN , OCTOBER 1988 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE inprod_I - USE prsym_I + USE inprod_I + USE prsym_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) - REAL(DOUBLE) :: L(*) - REAL(DOUBLE) :: U(*) + INTEGER :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) + REAL(DOUBLE) :: L(*) + REAL(DOUBLE) :: U(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: R, J, I, NTEST - REAL(DOUBLE) :: XFACI + INTEGER :: R, J, I, NTEST + REAL(DOUBLE) :: XFACI !----------------------------------------------- ! - DO R = 1, NDIM + DO R = 1, NDIM ! - DO J = R, NDIM - U(J*(J-1)/2+R) = A(R,J) - INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1) - END DO + DO J = R, NDIM + U(J*(J-1)/2+R) = A(R,J) - INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1) + END DO ! - XFACI = 1.0D0/U(R*(R+1)/2) - L(R*(R+1)/2) = 1.0D0 - DO I = R + 1, NDIM + XFACI = 1.0D0/U(R*(R+1)/2) + L(R*(R+1)/2) = 1.0D0 + DO I = R + 1, NDIM L(I*(I-1)/2+R) = (A(I,R)-INPROD(L(I*(I-1)/2+1),U(R*(R-1)/2+1),R-1))& - *XFACI - END DO + *XFACI + END DO ! - END DO + END DO ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' L MATRIX ' - CALL PRSYM (L, NDIM) - WRITE (6, *) ' U MATRIX ( TRANSPOSED ) ' - CALL PRSYM (U, NDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' L MATRIX ' + CALL PRSYM (L, NDIM) + WRITE (6, *) ' U MATRIX ( TRANSPOSED ) ' + CALL PRSYM (U, NDIM) + ENDIF ! - RETURN - END SUBROUTINE LULU + RETURN + END SUBROUTINE LULU diff --git a/src/appl/rbiotransform90/lulu_I.f90 b/src/appl/rbiotransform90/lulu_I.f90 index b5b84a34b..5369e8f2a 100644 --- a/src/appl/rbiotransform90/lulu_I.f90 +++ b/src/appl/rbiotransform90/lulu_I.f90 @@ -1,14 +1,14 @@ - MODULE lulu_I + MODULE lulu_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lulu (A, L, U, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: L - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: U - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lulu (A, L, U, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: L + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: U + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/matml4.f90 b/src/appl/rbiotransform90/matml4.f90 index dc029e48e..f2bc0fbeb 100644 --- a/src/appl/rbiotransform90/matml4.f90 +++ b/src/appl/rbiotransform90/matml4.f90 @@ -4,7 +4,7 @@ ! ------------------------------------------------------------------ ! SUBROUTINE MATML4(C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL, & - ITRNSP) + ITRNSP) ! ! MULTIPLY A AND B TO GIVE C ! @@ -17,89 +17,89 @@ SUBROUTINE MATML4(C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL, & !... JEPPE OLSEN, LAST REVISION JULY 24 1987 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE wrtmat_I - USE setvec_I + USE wrtmat_I + USE setvec_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCROW - INTEGER :: NCCOL - INTEGER :: NAROW - INTEGER :: NACOL - INTEGER :: NBROW - INTEGER :: NBCOL - INTEGER , INTENT(IN) :: ITRNSP - REAL(DOUBLE) :: C(NCROW,NCCOL) - REAL(DOUBLE) :: A(NAROW,NACOL) - REAL(DOUBLE) :: B(NBROW,NBCOL) + INTEGER :: NCROW + INTEGER :: NCCOL + INTEGER :: NAROW + INTEGER :: NACOL + INTEGER :: NBROW + INTEGER :: NBCOL + INTEGER , INTENT(IN) :: ITRNSP + REAL(DOUBLE) :: C(NCROW,NCCOL) + REAL(DOUBLE) :: A(NAROW,NACOL) + REAL(DOUBLE) :: B(NBROW,NBCOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTEST, J, K, I - REAL(DOUBLE) :: BKJ, BJK + INTEGER :: NTEST, J, K, I + REAL(DOUBLE) :: BKJ, BJK !----------------------------------------------- ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) - WRITE (6, *) ' A AND B MATRIX FROM MATML4 ' - WRITE (6, *) - CALL WRTMAT (A, NAROW, NACOL, NAROW, NACOL) - CALL WRTMAT (B, NBROW, NBCOL, NBROW, NBCOL) - WRITE (6, *) ' NCROW NCCOL NAROW NACOL NBROW NBCOL ' - WRITE (6, '(6I6)') NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL - ENDIF -! - CALL SETVEC (C, 0.0D0, NCROW*NCCOL) -! - IF (ITRNSP == 0) THEN - DO J = 1, NCCOL - DO K = 1, NBROW - BKJ = B(K,J) - C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BKJ - END DO - END DO - ENDIF -! -! - IF (ITRNSP == 1) THEN + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) + WRITE (6, *) ' A AND B MATRIX FROM MATML4 ' + WRITE (6, *) + CALL WRTMAT (A, NAROW, NACOL, NAROW, NACOL) + CALL WRTMAT (B, NBROW, NBCOL, NBROW, NBCOL) + WRITE (6, *) ' NCROW NCCOL NAROW NACOL NBROW NBCOL ' + WRITE (6, '(6I6)') NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL + ENDIF +! + CALL SETVEC (C, 0.0D0, NCROW*NCCOL) +! + IF (ITRNSP == 0) THEN + DO J = 1, NCCOL + DO K = 1, NBROW + BKJ = B(K,J) + C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BKJ + END DO + END DO + ENDIF +! +! + IF (ITRNSP == 1) THEN !... C = A(T) * B - DO J = 1, NCCOL - DO K = 1, NBROW - BKJ = B(K,J) - C(:NCROW,J) = C(:NCROW,J) + A(K,:NCROW)*BKJ - END DO - END DO - ENDIF -! - IF (ITRNSP == 2) THEN + DO J = 1, NCCOL + DO K = 1, NBROW + BKJ = B(K,J) + C(:NCROW,J) = C(:NCROW,J) + A(K,:NCROW)*BKJ + END DO + END DO + ENDIF +! + IF (ITRNSP == 2) THEN !... C = A*B(T) - DO J = 1, NCCOL - DO K = 1, NBCOL - BJK = B(J,K) - C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BJK - END DO - END DO - ENDIF -! -! - IF (NTEST /= 0) THEN - WRITE (6, *) - WRITE (6, *) ' C MATRIX FROM MATML4 ' - WRITE (6, *) - CALL WRTMAT (C, NCROW, NCCOL, NCROW, NCCOL) - ENDIF -! - RETURN - END SUBROUTINE MATML4 + DO J = 1, NCCOL + DO K = 1, NBCOL + BJK = B(J,K) + C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BJK + END DO + END DO + ENDIF +! +! + IF (NTEST /= 0) THEN + WRITE (6, *) + WRITE (6, *) ' C MATRIX FROM MATML4 ' + WRITE (6, *) + CALL WRTMAT (C, NCROW, NCCOL, NCROW, NCCOL) + ENDIF +! + RETURN + END SUBROUTINE MATML4 diff --git a/src/appl/rbiotransform90/matml4_I.f90 b/src/appl/rbiotransform90/matml4_I.f90 index acdc552d2..766630d3a 100644 --- a/src/appl/rbiotransform90/matml4_I.f90 +++ b/src/appl/rbiotransform90/matml4_I.f90 @@ -1,21 +1,21 @@ - MODULE matml4_I + MODULE matml4_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE matml4 (C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL& - , ITRNSP) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCROW,NCCOL), INTENT(INOUT) :: C - REAL(DOUBLE), DIMENSION(NAROW,NACOL), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(NBROW,NBCOL), INTENT(IN) :: B - INTEGER, INTENT(IN) :: NCROW - INTEGER, INTENT(IN) :: NCCOL - INTEGER, INTENT(IN) :: NAROW - INTEGER, INTENT(IN) :: NACOL - INTEGER, INTENT(IN) :: NBROW - INTEGER, INTENT(IN) :: NBCOL - INTEGER, INTENT(IN) :: ITRNSP - END SUBROUTINE - END INTERFACE - END MODULE + , ITRNSP) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCROW,NCCOL), INTENT(INOUT) :: C + REAL(DOUBLE), DIMENSION(NAROW,NACOL), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(NBROW,NBCOL), INTENT(IN) :: B + INTEGER, INTENT(IN) :: NCROW + INTEGER, INTENT(IN) :: NCCOL + INTEGER, INTENT(IN) :: NAROW + INTEGER, INTENT(IN) :: NACOL + INTEGER, INTENT(IN) :: NBROW + INTEGER, INTENT(IN) :: NBCOL + INTEGER, INTENT(IN) :: ITRNSP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/mcpin.f90 b/src/appl/rbiotransform90/mcpin.f90 index ea3750815..cb00b1ca5 100644 --- a/src/appl/rbiotransform90/mcpin.f90 +++ b/src/appl/rbiotransform90/mcpin.f90 @@ -20,7 +20,7 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) ! Bug corrected 2005-10-18 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -65,11 +65,11 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) INTEGER, PARAMETER :: KEY = KEYORB, KEYSQ = KEY*KEY, nvmax=100 REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 INTEGER, PARAMETER :: NF = 200 - + LOGICAL :: F0INT,LINCR,RESTRT,COMP,AVAIL CHARACTER(LEN=20) :: CNUM CHARACTER(LEN=2) :: CK -! +! REAL(DOUBLE), DIMENSION(NNNW) :: tshell REAL(DOUBLE), DIMENSION(NVMAX) ::SC INTEGER, DIMENSION(NNNW) :: nakinv @@ -92,55 +92,55 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) NSHL(I) = NSHLII(I) NINL(I) = NINII(I) ENDDO - + DO I = 1,NNNW NAKINV(I) = NAKINVII(I) ENDDO - + DO J = 1,NLMAX DO I = 1,NLMAX NSHLP(I,J) = NSHLPII(I,J) ENDDO ENDDO - + DO J = 1,NNNW DO I = 1,NLMAX NSHLPP(I,J) = NSHLPPII(I,J) ENDDO ENDDO - + DO I = 1,20*NLMAX*NLMAX CIROT(I) = CICI(I) ENDDO - + ELSEIF (IK.EQ.2) THEN - + DO I = 1,NLMAX NSHL(I) = NSHLFF(I) NINL(I) = NINFF(I) ENDDO - + DO I = 1,NNNW NAKINV(I) = NAKINVFF(I) ENDDO - + DO J = 1,NLMAX DO I = 1,NLMAX NSHLP(I,J) = NSHLPFF(I,J) ENDDO ENDDO - + DO J = 1,NNNW DO I = 1,NLMAX NSHLPP(I,J) = NSHLPPFF(I,J) ENDDO ENDDO - + DO I = 1,20*NLMAX*NLMAX CIROT(I) = CFCI(I) ENDDO ENDIF - + REWIND (NF) DO 1000 IBLK = 1, NBLOCK ! @@ -158,7 +158,7 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) ! READ(NF) NCFD,NWD,KAMAXD DO L = 1,KAMAX - + !************ ! !. Offset for given L in shell matrices @@ -169,9 +169,9 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) IIOFF = IIOFF + NSHL(L-1)** 2 END IF ! Corrected PER J - + !************** - + READ(NF) NINTG,NCOEFF IF(NCOEFF*NINTG.EQ.0) CYCLE ! @@ -184,7 +184,7 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) CALL ALLOC (INTGRL,NINTG, 'INTGRL', 'MCPIN') CALL ALLOC (CNN,NCOEFF, 'CNN', 'MCPIN') CALL ALLOC (INTPTR,NINTG, 'INTPTR', 'MCPIN') - + DO I = 1,NINTG READ(NF) INTGRL(I),INTPTR(I) ENDDO @@ -214,9 +214,9 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) CALL DALLOC (INTGRL, 'INTGRL', 'MCPIN') CALL DALLOC (CNN, 'CNN', 'MCPIN') CALL DALLOC (INTPTR, 'INTPRT', 'MCPIN') - + ENDDO - + CALL dalloc (scr, 'SCR', 'MCPIN') CALL dalloc (ciout, 'CIOUT', 'MCPIN') ! @@ -231,17 +231,17 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) OPEN (UNIT = 31,FILE=NAME(1:J-1)//'.bm',FORM='UNFORMATTED', & & STATUS='UNKNOWN') ENDIF - + WRITE(31) 'G92MIX' WRITE(31) NELEC,NCFTOT,NW,NVECTOT,NVECSIZE,NBLOCK ENDIF - + WRITE(31) IBLK,NCF,NVEC,IATJPO(1),IASPAR(1) WRITE(31) (IVEC(I),I = 1,NVEC) ! WRITE(31) (IATJPO(I),IASPAR(I),I = 1,NVEC) WRITE(31) EAV,(EVAL(I),I = 1,NVEC) WRITE(31) ((EVEC(I+(J-1)*NCF),I = 1,NCF),J = 1,NVEC) - + CALL DALLOC (EVAL, 'EVAL', 'MCPIN') CALL DALLOC (EVEC, 'EVEC', 'MCPIN') CALL DALLOC (IVEC, 'IVEC', 'MCPIN') @@ -256,4 +256,4 @@ SUBROUTINE MCPIN (NAME,IK,NTESTG,INPCI) CLOSE (31) ! RETURN - END SUBROUTINE MCPIN + END SUBROUTINE MCPIN diff --git a/src/appl/rbiotransform90/mcpin_I.f90 b/src/appl/rbiotransform90/mcpin_I.f90 index 55845e2f6..b833bf6c9 100644 --- a/src/appl/rbiotransform90/mcpin_I.f90 +++ b/src/appl/rbiotransform90/mcpin_I.f90 @@ -1,12 +1,12 @@ - MODULE mcpin_I + MODULE mcpin_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mcpin (NAME, IK, NTESTG, INPCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mcpin (NAME, IK, NTESTG, INPCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/mcpout_gg.f90 b/src/appl/rbiotransform90/mcpout_gg.f90 index fb47c973d..7f86f7311 100644 --- a/src/appl/rbiotransform90/mcpout_gg.f90 +++ b/src/appl/rbiotransform90/mcpout_gg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCPOUT(NAME, IK, NTESTG, INPCI) + SUBROUTINE MCPOUT(NAME, IK, NTESTG, INPCI) ! * ! This routine controls the computation and storage of the values * ! and all indices of the angular coefficients * @@ -19,21 +19,21 @@ SUBROUTINE MCPOUT(NAME, IK, NTESTG, INPCI) ! Written by Per Jonsson Last revision: JUne 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, KEYORB USE memory_man - USE FOPARM_C - USE MCP_C - USE PRNT_C - USE SYMA_C - USE STAT_C - USE BLK_C + USE FOPARM_C + USE MCP_C + USE PRNT_C + USE SYMA_C + USE STAT_C + USE BLK_C USE orb_C, ONLY: ncf, nw,nak, iqa USE jqjc_C USE orbord_C @@ -43,199 +43,199 @@ SUBROUTINE MCPOUT(NAME, IK, NTESTG, INPCI) ! I n t e r f a c e B l o c k s !----------------------------------------------- USE onescalar_I - USE cord_I - USE itjpo_I - USE angdata_I - USE qqsort_I + USE cord_I + USE itjpo_I + USE angdata_I + USE qqsort_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - CHARACTER :: NAME*24 + INTEGER :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + CHARACTER :: NAME*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NF = 200 - INTEGER, PARAMETER :: NVMAX = 100 + INTEGER, PARAMETER :: NF = 200 + INTEGER, PARAMETER :: NVMAX = 100 INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: KEYSQ = KEY*KEY - REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 + INTEGER, PARAMETER :: KEYSQ = KEY*KEY + REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NLMAX) :: LLISTT - INTEGER, DIMENSION(NNNW) :: NAKINV - INTEGER, DIMENSION(NLMAX) :: NSHL, NINL + INTEGER, DIMENSION(NLMAX) :: LLISTT + INTEGER, DIMENSION(NNNW) :: NAKINV + INTEGER, DIMENSION(NLMAX) :: NSHL, NINL INTEGER :: I, NTESTL, NTEST, KA, IOPAR, J, NCF0, IBLK, K, & - JA, JB, IBB, IA, IB, LAB, JAN, JBN, L - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL - REAL(DOUBLE), DIMENSION(NVMAX) :: SC - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CIROT - REAL(DOUBLE), DIMENSION(10000) :: EVSC - LOGICAL :: F0INT, LINCR, RESTRT, COMP, AVAIL - CHARACTER :: CNUM*20, CK*2 + JA, JB, IBB, IA, IB, LAB, JAN, JBN, L + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + REAL(DOUBLE), DIMENSION(NVMAX) :: SC + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CIROT + REAL(DOUBLE), DIMENSION(10000) :: EVSC + LOGICAL :: F0INT, LINCR, RESTRT, COMP, AVAIL + CHARACTER :: CNUM*20, CK*2 !----------------------------------------------- ! ! Locals ! POINTER (pscr, scr(1)) ! POINTER (pciout, ciout(1)) ! - - WRITE (6, *) 'NBLOCK,(NCFBLK(i),i=1,NBLOCK)' - WRITE (6, *) NBLOCK, (NCFBLK(I),I=1,NBLOCK) - - NTESTL = 0 - NTEST = MAX(NTESTG,NTESTL) - NTEST = 0 + + WRITE (6, *) 'NBLOCK,(NCFBLK(i),i=1,NBLOCK)' + WRITE (6, *) NBLOCK, (NCFBLK(I),I=1,NBLOCK) + + NTESTL = 0 + NTEST = MAX(NTESTG,NTESTL) + NTEST = 0 ! ! Set the rank (zero) and parity (even) for the one-particle ! coefficients ! - KA = 0 - IOPAR = 1 + KA = 0 + IOPAR = 1 ! ! Check if angular data is available. If available read this data. ! If not available calculate the data ! - CALL ANGDATA (NAME, AVAIL, KAMAX) - WRITE (6, *) 'AVAIL=', AVAIL - IF (AVAIL) RETURN - - IF (IK == 1) THEN - NAKINV(:NNNW) = NAKINVII(:NNNW) - ELSE - NAKINV(:NNNW) = NAKINVFF(:NNNW) - ENDIF - - - - WRITE (6, *) ' open sorted ang. file .TB(NF)', NF - J = INDEX(NAME,' ') + CALL ANGDATA (NAME, AVAIL, KAMAX) + WRITE (6, *) 'AVAIL=', AVAIL + IF (AVAIL) RETURN + + IF (IK == 1) THEN + NAKINV(:NNNW) = NAKINVII(:NNNW) + ELSE + NAKINV(:NNNW) = NAKINVFF(:NNNW) + ENDIF + + + + WRITE (6, *) ' open sorted ang. file .TB(NF)', NF + J = INDEX(NAME,' ') OPEN(UNIT=NF, FILE=NAME(1:J-1)//'.TB', STATUS='UNKNOWN', FORM=& - 'UNFORMATTED', POSITION='asis') - - NCF0 = 1 - DO IBLK = 1, NBLOCK + 'UNFORMATTED', POSITION='asis') + + NCF0 = 1 + DO IBLK = 1, NBLOCK ! ! Open scratchfiles to dump the T coefficients for each kappa ! - DO K = 1, KAMAX + DO K = 1, KAMAX OPEN(UNIT=80 + K, STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - END DO + 'asis') + END DO ! ! Initialize the counters for the total number of T coefficients ! - LLISTT(:NLMAX) = 0 + LLISTT(:NLMAX) = 0 ! ! JA and JB respectively refer to the initial and final states ! in the list of NCF configurations ! - DO JA = NCF0, NCFBLK(IBLK) - IF (MOD(JA,100)==0 .AND. IK==1) THEN - WRITE (*, *) ' JA1 =', JA, JA - NCF0 + 1 - ELSE IF (MOD(JA,100)==0 .AND. IK==2) THEN - WRITE (*, *) ' JA2 =', JA, JA - NCF0 + 1 - ENDIF + DO JA = NCF0, NCFBLK(IBLK) + IF (MOD(JA,100)==0 .AND. IK==1) THEN + WRITE (*, *) ' JA1 =', JA, JA - NCF0 + 1 + ELSE IF (MOD(JA,100)==0 .AND. IK==2) THEN + WRITE (*, *) ' JA2 =', JA, JA - NCF0 + 1 + ENDIF ! - DO JB = NCF0, NCFBLK(IBLK) + DO JB = NCF0, NCFBLK(IBLK) ! ! Call the MCT package to compute T coefficients ! - IF (NTRANS == 1) THEN - COMP = .FALSE. - IF (IK == 1) THEN - DO IBB = 1, JQJ1 - IF (ITJPO(JA) /= ITJQJ1(IBB)) CYCLE - COMP = .TRUE. - END DO - ELSE - DO IBB = 1, JQJ2 - IF (ITJPO(JA) /= ITJQJ2(IBB)) CYCLE - COMP = .TRUE. - END DO - ENDIF - ELSE - COMP = .TRUE. - ENDIF - - - IF (.NOT.COMP) CYCLE + IF (NTRANS == 1) THEN + COMP = .FALSE. + IF (IK == 1) THEN + DO IBB = 1, JQJ1 + IF (ITJPO(JA) /= ITJQJ1(IBB)) CYCLE + COMP = .TRUE. + END DO + ELSE + DO IBB = 1, JQJ2 + IF (ITJPO(JA) /= ITJQJ2(IBB)) CYCLE + COMP = .TRUE. + END DO + ENDIF + ELSE + COMP = .TRUE. + ENDIF + + + IF (.NOT.COMP) CYCLE ! write(*,*) JA,JB -!GG CALL TNSRJJ (KA, IOPAR, JA, JB, IA, IB, TSHELL) +!GG CALL TNSRJJ (KA, IOPAR, JA, JB, IA, IB, TSHELL) CALL ONESCALAR(JA,JB,IA,IB,TSHELL) - IF (IA == 0) CYCLE - IF (IA == IB) THEN - DO IA = 1, NW + IF (IA == 0) CYCLE + IF (IA == IB) THEN + DO IA = 1, NW ! ! If T coefficient is greater than zero and the kappa quantum numbers ! of the two orbitals are the same dump to file ! In a later version use a buffer with a reasonable record length ! - IF (DABS(TSHELL(IA)) <= CUTOFF) CYCLE - LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 - LAB = IA*KEY + IA + IF (DABS(TSHELL(IA)) <= CUTOFF) CYCLE + LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 + LAB = IA*KEY + IA WRITE (80 + NAKINV(IA)) JA - NCF0 + 1, JB - NCF0 + 1, LAB& - , TSHELL(IA) - END DO - ELSE - IF (DABS(TSHELL(1))>CUTOFF .AND. NAK(IA)==NAK(IB)) THEN - LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 - IF (NORDII==0 .AND. NORDFF==0) THEN + , TSHELL(IA) + END DO + ELSE + IF (DABS(TSHELL(1))>CUTOFF .AND. NAK(IA)==NAK(IB)) THEN + LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 + IF (NORDII==0 .AND. NORDFF==0) THEN ! ! Experssion for normal orbital ordering ! - LAB = IA*KEY + IB - JAN = JA - NCF0 + 1 - JBN = JB - NCF0 + 1 - ELSE IF (NORDII==1 .AND. NORDFF==1) THEN + LAB = IA*KEY + IB + JAN = JA - NCF0 + 1 + JBN = JB - NCF0 + 1 + ELSE IF (NORDII==1 .AND. NORDFF==1) THEN ! ! Experssion for reversed orbital ordering ! - LAB = IB*KEY + IA - JAN = JB - NCF0 + 1 - JBN = JA - NCF0 + 1 - ELSE + LAB = IB*KEY + IA + JAN = JB - NCF0 + 1 + JBN = JA - NCF0 + 1 + ELSE WRITE (*, *) 'SOMETHING WRONG' STOP - ENDIF - WRITE (80 + NAKINV(IA)) JAN, JBN, LAB, TSHELL(1) - ENDIF - ENDIF + ENDIF + WRITE (80 + NAKINV(IA)) JAN, JBN, LAB, TSHELL(1) + ENDIF + ENDIF ! - END DO - END DO - - + END DO + END DO + + ! ! sort the MCP data into inegral based lists. ! - DO L = 1, KAMAX - IF (LLISTT(L) > 0) THEN - CALL QQSORT (L, LLISTT(L), IK, NAME, KAMAX) - ELSE - IF (L == 1) WRITE (NF) NCF, NW, KAMAX - WRITE (NF) LLISTT(L), LLISTT(L) - ENDIF - END DO + DO L = 1, KAMAX + IF (LLISTT(L) > 0) THEN + CALL QQSORT (L, LLISTT(L), IK, NAME, KAMAX) + ELSE + IF (L == 1) WRITE (NF) NCF, NW, KAMAX + WRITE (NF) LLISTT(L), LLISTT(L) + ENDIF + END DO ! ! Close the angular files ! - DO L = 1, KAMAX - CLOSE(L + 80, STATUS='DELETE') - END DO + DO L = 1, KAMAX + CLOSE(L + 80, STATUS='DELETE') + END DO ! - NCF0 = NCFBLK(IBLK) + 1 - END DO + NCF0 = NCFBLK(IBLK) + 1 + END DO ! ! Deallocate storage that is no longer required. This was ! allocated in lodcsl. ! - CALL DALLOC (IQA, 'IQA', 'MCPOUT') - CALL DALLOC (JQSA, 'JQSA', 'MCPOUT') - CALL DALLOC (JCUPA, 'JCUPA', 'MCPOUT') - RETURN - END SUBROUTINE MCPOUT + CALL DALLOC (IQA, 'IQA', 'MCPOUT') + CALL DALLOC (JQSA, 'JQSA', 'MCPOUT') + CALL DALLOC (JCUPA, 'JCUPA', 'MCPOUT') + RETURN + END SUBROUTINE MCPOUT diff --git a/src/appl/rbiotransform90/mcpout_gg_I.f90 b/src/appl/rbiotransform90/mcpout_gg_I.f90 index d11675a46..d8d2af48e 100644 --- a/src/appl/rbiotransform90/mcpout_gg_I.f90 +++ b/src/appl/rbiotransform90/mcpout_gg_I.f90 @@ -1,13 +1,13 @@ - MODULE mcpout_I + MODULE mcpout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mcpout (NAME, IK, NTESTG, INPCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mcpout (NAME, IK, NTESTG, INPCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/orbord.f90 b/src/appl/rbiotransform90/orbord.f90 index 20fbcc42f..a0e2539dd 100644 --- a/src/appl/rbiotransform90/orbord.f90 +++ b/src/appl/rbiotransform90/orbord.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ORBORD(N) + SUBROUTINE ORBORD(N) ! * ! THIS ROUTINE DOES NOTHING! @@ -11,23 +11,23 @@ SUBROUTINE ORBORD(N) ! Written by Per Jonsson Last revision: Feb 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE orb_C USE biorb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N + INTEGER :: N !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - - RETURN - END SUBROUTINE ORBORD + + RETURN + END SUBROUTINE ORBORD diff --git a/src/appl/rbiotransform90/orbord_I.f90 b/src/appl/rbiotransform90/orbord_I.f90 index f18f618c6..58758ace5 100644 --- a/src/appl/rbiotransform90/orbord_I.f90 +++ b/src/appl/rbiotransform90/orbord_I.f90 @@ -1,11 +1,11 @@ - MODULE orbord_I + MODULE orbord_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orbord (N) - INTEGER :: N + SUBROUTINE orbord (N) + INTEGER :: N !...Dummy argument N is not referenced in this routine. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/pamtmt.f90 b/src/appl/rbiotransform90/pamtmt.f90 index 041d8083b..e934379f3 100644 --- a/src/appl/rbiotransform90/pamtmt.f90 +++ b/src/appl/rbiotransform90/pamtmt.f90 @@ -3,7 +3,7 @@ ! P A M T M T ! ------------------------------------------------------------------ ! - SUBROUTINE PAMTMT(X, T, WORK, NORB) + SUBROUTINE PAMTMT(X, T, WORK, NORB) ! ! GENERATE PER AKE'S T MATRIX FROM A ! ORBITAL ROTATION MATRIX X @@ -23,72 +23,72 @@ SUBROUTINE PAMTMT(X, T, WORK, NORB) ! JEPPE OLSEN OCTOBER 1988 ! !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lulu_I - USE setvec_I - USE wrtmat_I - USE invmat_I + USE lulu_I + USE setvec_I + USE wrtmat_I + USE invmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NORB - REAL(DOUBLE) :: X(NORB,NORB) - REAL(DOUBLE) :: T(NORB,NORB) - REAL(DOUBLE) :: WORK(*) + INTEGER :: NORB + REAL(DOUBLE) :: X(NORB,NORB) + REAL(DOUBLE) :: T(NORB,NORB) + REAL(DOUBLE) :: WORK(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTEST, KLFREE, KLL, KLU, I, J + INTEGER :: NTEST, KLFREE, KLL, KLU, I, J !----------------------------------------------- ! DIMENSION OF WORK : NORB ** 2 + NORB*(NORB+1) / 2 ! - NTEST = 0 + NTEST = 0 !. Allocate local memory - KLFREE = 1 + KLFREE = 1 ! KLL = KFLREE - KLL = KLFREE - KLFREE = KLL + NORB*(NORB + 1)/2 - KLU = KLFREE - KLFREE = KLU + NORB**2 + KLL = KLFREE + KLFREE = KLL + NORB*(NORB + 1)/2 + KLU = KLFREE + KLFREE = KLU + NORB**2 !.LU factorize X - CALL LULU (X, WORK(KLL), WORK(KLU), NORB) + CALL LULU (X, WORK(KLL), WORK(KLU), NORB) !.Expand U to full matrix - CALL SETVEC (T, 0.0D0, NORB**2) - DO I = 1, NORB - DO J = I, NORB - T(I,J) = WORK(KLU-1+J*(J-1)/2+I) - END DO - END DO - IF (NTEST >= 10) THEN - WRITE (6, *) ' MATRIX TO BE INVERTED ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + CALL SETVEC (T, 0.0D0, NORB**2) + DO I = 1, NORB + DO J = I, NORB + T(I,J) = WORK(KLU-1+J*(J-1)/2+I) + END DO + END DO + IF (NTEST >= 10) THEN + WRITE (6, *) ' MATRIX TO BE INVERTED ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF !.Invert U - CALL INVMAT (T, WORK(KLU), NORB, NORB) - IF (NTEST >= 10) THEN - WRITE (6, *) ' INVERTED MATRIX ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + CALL INVMAT (T, WORK(KLU), NORB, NORB) + IF (NTEST >= 10) THEN + WRITE (6, *) ' INVERTED MATRIX ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF !.Subtract L - DO I = 1, NORB - T(I,:I-1) = -WORK(KLL+I*(I-1)/2:I-2+KLL+I*(I-1)/2) - END DO + DO I = 1, NORB + T(I,:I-1) = -WORK(KLL+I*(I-1)/2:I-2+KLL+I*(I-1)/2) + END DO ! - IF (NTEST /= 0) THEN - WRITE (6, *) ' INPUT X MATRIX ' - CALL WRTMAT (X, NORB, NORB, NORB, NORB) - WRITE (6, *) ' T MATRIX ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + IF (NTEST /= 0) THEN + WRITE (6, *) ' INPUT X MATRIX ' + CALL WRTMAT (X, NORB, NORB, NORB, NORB) + WRITE (6, *) ' T MATRIX ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF ! - RETURN - END SUBROUTINE PAMTMT + RETURN + END SUBROUTINE PAMTMT diff --git a/src/appl/rbiotransform90/pamtmt_I.f90 b/src/appl/rbiotransform90/pamtmt_I.f90 index acde6d6c2..dea18e68d 100644 --- a/src/appl/rbiotransform90/pamtmt_I.f90 +++ b/src/appl/rbiotransform90/pamtmt_I.f90 @@ -1,14 +1,14 @@ - MODULE pamtmt_I + MODULE pamtmt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE pamtmt (X, T, WORK, NORB) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NORB,NORB) :: X - REAL(DOUBLE), DIMENSION(NORB,NORB), INTENT(OUT) :: T - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: WORK - INTEGER, INTENT(IN) :: NORB - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE pamtmt (X, T, WORK, NORB) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NORB,NORB) :: X + REAL(DOUBLE), DIMENSION(NORB,NORB), INTENT(OUT) :: T + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: WORK + INTEGER, INTENT(IN) :: NORB + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/prsym.f90 b/src/appl/rbiotransform90/prsym.f90 index ed5801885..6c63a33b6 100644 --- a/src/appl/rbiotransform90/prsym.f90 +++ b/src/appl/rbiotransform90/prsym.f90 @@ -2,36 +2,36 @@ ! P R S Y M ! ------------------------------------------------------------------ ! - SUBROUTINE PRSYM(A, MATDIM) + SUBROUTINE PRSYM(A, MATDIM) ! PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. ! THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MATDIM - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A + INTEGER, INTENT(IN) :: MATDIM + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: JSTART, JSTOP, I, J -!----------------------------------------------- - JSTART = 1 - JSTOP = 0 - DO I = 1, MATDIM - JSTART = JSTART + I - 1 - JSTOP = JSTOP + I - WRITE (6, 1010) I, (A(J),J=JSTART,JSTOP) - END DO - RETURN - 1010 FORMAT('0',2X,I3,5(1X,E14.7),/,(' ',5X,5(1X,E14.7))) - RETURN - END SUBROUTINE PRSYM + INTEGER :: JSTART, JSTOP, I, J +!----------------------------------------------- + JSTART = 1 + JSTOP = 0 + DO I = 1, MATDIM + JSTART = JSTART + I - 1 + JSTOP = JSTOP + I + WRITE (6, 1010) I, (A(J),J=JSTART,JSTOP) + END DO + RETURN + 1010 FORMAT('0',2X,I3,5(1X,E14.7),/,(' ',5X,5(1X,E14.7))) + RETURN + END SUBROUTINE PRSYM diff --git a/src/appl/rbiotransform90/prsym_I.f90 b/src/appl/rbiotransform90/prsym_I.f90 index 2dd2ac146..29e84b8a7 100644 --- a/src/appl/rbiotransform90/prsym_I.f90 +++ b/src/appl/rbiotransform90/prsym_I.f90 @@ -1,13 +1,13 @@ - MODULE prsym_I + MODULE prsym_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prsym (A, MATDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(1), INTENT(IN) :: A - INTEGER, INTENT(IN) :: MATDIM + SUBROUTINE prsym (A, MATDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(1), INTENT(IN) :: A + INTEGER, INTENT(IN) :: MATDIM !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/qqsort.f90 b/src/appl/rbiotransform90/qqsort.f90 index 9d6662f43..64c026f49 100644 --- a/src/appl/rbiotransform90/qqsort.f90 +++ b/src/appl/rbiotransform90/qqsort.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) + SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! * ! The list of unique integrals (j,i) is formed in the order of * ! increasing symmetry, i.e. with j .le. i. * @@ -21,13 +21,13 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE orb_C @@ -40,128 +40,128 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NUMBER - INTEGER :: KSTART - INTEGER, INTENT(IN) :: KAMAX - CHARACTER :: NAME*24 + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NUMBER + INTEGER :: KSTART + INTEGER, INTENT(IN) :: KAMAX + CHARACTER :: NAME*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: NF = 200 + INTEGER, PARAMETER :: NF = 200 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, L, IR, JA, JB, INT, J, INTT - REAL(DOUBLE) :: CN + REAL(DOUBLE) :: CN !----------------------------------------------- ! - REWIND (NFILE + 80) - - NCOEFF = NUMBER + REWIND (NFILE + 80) + + NCOEFF = NUMBER ! ! Sort the list ! ! Allocate storage for all required arrays these arrays are then deallocated ! in mcp ! - CALL ALLOC (JANN, NCOEFF, 'JANN', 'QQSORT') - CALL ALLOC (JBNN, NCOEFF, 'JBNN', 'QQSORT') - CALL ALLOC (INTGRL, NCOEFF, 'INTGRL', 'QQSORT') - CALL ALLOC (CNN, NCOEFF, 'CNN', 'QQSORT') - CALL ALLOC (INTPTR, NCOEFF, 'INTPTR', 'QQSORT') + CALL ALLOC (JANN, NCOEFF, 'JANN', 'QQSORT') + CALL ALLOC (JBNN, NCOEFF, 'JBNN', 'QQSORT') + CALL ALLOC (INTGRL, NCOEFF, 'INTGRL', 'QQSORT') + CALL ALLOC (CNN, NCOEFF, 'CNN', 'QQSORT') + CALL ALLOC (INTPTR, NCOEFF, 'INTPTR', 'QQSORT') ! ! Read arrays into memory from NFILE ! - DO I = 1, NCOEFF - READ (NFILE + 80) JANN(I), JBNN(I), INTGRL(I), CNN(I) - END DO + DO I = 1, NCOEFF + READ (NFILE + 80) JANN(I), JBNN(I), INTGRL(I), CNN(I) + END DO ! ! Sort INTGRL into ascending order using the heapsort algorithm; ! (Numerical recepies page 231.) move the associated members of ! of JANN and JBNN in the same ! manner; ! - IF (NCOEFF > 1) THEN -! - L = NCOEFF/2 + 1 - IR = NCOEFF - 2 CONTINUE - IF (L > 1) THEN - L = L - 1 - JA = JANN(L) - JB = JBNN(L) - INT = INTGRL(L) - CN = CNN(L) - ELSE - JA = JANN(IR) - JB = JBNN(IR) - INT = INTGRL(IR) - CN = CNN(IR) - JANN(IR) = JANN(1) - JBNN(IR) = JBNN(1) - INTGRL(IR) = INTGRL(1) - CNN(IR) = CNN(1) - IR = IR - 1 - IF (IR == 1) THEN - JANN(1) = JA - JBNN(1) = JB - INTGRL(1) = INT - CNN(1) = CN - GO TO 4 - ENDIF - ENDIF - I = L - J = L + L - 3 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (INTGRL(J) < INTGRL(J+1)) J = J + 1 - ENDIF - IF (INT < INTGRL(J)) THEN - JANN(I) = JANN(J) - JBNN(I) = JBNN(J) - INTGRL(I) = INTGRL(J) - CNN(I) = CNN(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 3 - ENDIF - JANN(I) = JA - JBNN(I) = JB - INTGRL(I) = INT - CNN(I) = CN - GO TO 2 - ENDIF -! - + IF (NCOEFF > 1) THEN +! + L = NCOEFF/2 + 1 + IR = NCOEFF + 2 CONTINUE + IF (L > 1) THEN + L = L - 1 + JA = JANN(L) + JB = JBNN(L) + INT = INTGRL(L) + CN = CNN(L) + ELSE + JA = JANN(IR) + JB = JBNN(IR) + INT = INTGRL(IR) + CN = CNN(IR) + JANN(IR) = JANN(1) + JBNN(IR) = JBNN(1) + INTGRL(IR) = INTGRL(1) + CNN(IR) = CNN(1) + IR = IR - 1 + IF (IR == 1) THEN + JANN(1) = JA + JBNN(1) = JB + INTGRL(1) = INT + CNN(1) = CN + GO TO 4 + ENDIF + ENDIF + I = L + J = L + L + 3 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (INTGRL(J) < INTGRL(J+1)) J = J + 1 + ENDIF + IF (INT < INTGRL(J)) THEN + JANN(I) = JANN(J) + JBNN(I) = JBNN(J) + INTGRL(I) = INTGRL(J) + CNN(I) = CNN(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 3 + ENDIF + JANN(I) = JA + JBNN(I) = JB + INTGRL(I) = INT + CNN(I) = CN + GO TO 2 + ENDIF +! + ! Sorting complete; close the file ! !ww 4 CLOSE (80+NFILE) - 4 CONTINUE - NINTG = 1 - INTT = INTGRL(1) -! - DO I = 1, NCOEFF - IF (INTGRL(I) == INTT) CYCLE - INTPTR(NINTG) = I - 1 - NINTG = NINTG + 1 - INTT = INTGRL(I) - END DO - - INTPTR(NINTG) = NCOEFF -! - DO I = 1, NINTG - INTGRL(I) = INTGRL(INTPTR(I)) - END DO + 4 CONTINUE + NINTG = 1 + INTT = INTGRL(1) +! + DO I = 1, NCOEFF + IF (INTGRL(I) == INTT) CYCLE + INTPTR(NINTG) = I - 1 + NINTG = NINTG + 1 + INTT = INTGRL(I) + END DO + + INTPTR(NINTG) = NCOEFF +! + DO I = 1, NINTG + INTGRL(I) = INTGRL(INTPTR(I)) + END DO ! ! If output option is set dump the data on file ! - IF (NDUMP == 1) THEN + IF (NDUMP == 1) THEN ! ! If first set of data open the file and print ! some data to later be able to identify the file @@ -173,29 +173,29 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! : STATUS='UNKNOWN',FORM='UNFORMATTED') ! REWIND (NF) ! ENDIF - IF (NFILE == 1) WRITE (NF) NCF, NW, KAMAX + IF (NFILE == 1) WRITE (NF) NCF, NW, KAMAX ! ! Print out angular data for this kappa ! - WRITE (NF) NINTG, NCOEFF - DO I = 1, NINTG - WRITE (NF) INTGRL(I), INTPTR(I) - END DO - DO I = 1, NCOEFF - WRITE (NF) CNN(I), JANN(I), JBNN(I) - END DO - ENDIF - CALL DALLOC (JANN, 'JANN', 'QQSORT') - CALL DALLOC (JBNN, 'JBNN', 'QQSORT') - CALL DALLOC (INTGRL, 'INTGRL', 'QQSORT') - CALL DALLOC (CNN, 'CNN', 'QQSORT') - CALL DALLOC (INTPTR, 'INTPTR', 'QQSORT') + WRITE (NF) NINTG, NCOEFF + DO I = 1, NINTG + WRITE (NF) INTGRL(I), INTPTR(I) + END DO + DO I = 1, NCOEFF + WRITE (NF) CNN(I), JANN(I), JBNN(I) + END DO + ENDIF + CALL DALLOC (JANN, 'JANN', 'QQSORT') + CALL DALLOC (JBNN, 'JBNN', 'QQSORT') + CALL DALLOC (INTGRL, 'INTGRL', 'QQSORT') + CALL DALLOC (CNN, 'CNN', 'QQSORT') + CALL DALLOC (INTPTR, 'INTPTR', 'QQSORT') ! ! Has all data been processed? If so close ! the file ! ! IF (NFILE.EQ.KAMAX) CLOSE (NF) - + ! Debug output ! ! IF (KSTART.EQ.1) THEN @@ -214,10 +214,10 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! WRITE(NNNN+NFILE,'(F12.8,2I6)') ! : (CNN(I),JANN(I),JBNN(I),I=1,NCOEFF) ! - RETURN + RETURN ! - 301 FORMAT(' T_[',1I2,',',1I2,']',' (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) - 302 FORMAT(' (',1I2,1A2,',',1I2,1A2,')',I6) - RETURN + 301 FORMAT(' T_[',1I2,',',1I2,']',' (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) + 302 FORMAT(' (',1I2,1A2,',',1I2,1A2,')',I6) + RETURN ! - END SUBROUTINE QQSORT + END SUBROUTINE QQSORT diff --git a/src/appl/rbiotransform90/qqsort_I.f90 b/src/appl/rbiotransform90/qqsort_I.f90 index e951cb838..8f7c42719 100644 --- a/src/appl/rbiotransform90/qqsort_I.f90 +++ b/src/appl/rbiotransform90/qqsort_I.f90 @@ -1,16 +1,16 @@ - MODULE qqsort_I + MODULE qqsort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qqsort (NFILE, NUMBER, KSTART, NAME, KAMAX) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NUMBER - INTEGER :: KSTART + SUBROUTINE qqsort (NFILE, NUMBER, KSTART, NAME, KAMAX) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NUMBER + INTEGER :: KSTART !...Dummy argument KSTART is not referenced in this routine. - CHARACTER (LEN = 24) :: NAME + CHARACTER (LEN = 24) :: NAME !...Dummy argument NAME is not referenced in this routine. - INTEGER, INTENT(IN) :: KAMAX - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: KAMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/radfile.f90 b/src/appl/rbiotransform90/radfile.f90 index 574ff9208..5bb564a37 100644 --- a/src/appl/rbiotransform90/radfile.f90 +++ b/src/appl/rbiotransform90/radfile.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE RADFILE(NAME) + SUBROUTINE RADFILE(NAME) ! * ! This subroutine outputs the transformed radial orbitals * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE grid_C USE orb_C @@ -25,40 +25,40 @@ SUBROUTINE RADFILE(NAME) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER, INTENT(IN) :: NAME(2)*24 + CHARACTER, INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, K, I + INTEGER :: J, K, I !----------------------------------------------- ! - J = INDEX(NAME(1),' ') + J = INDEX(NAME(1),' ') OPEN(UNIT=30, FILE=NAME(1)(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - - WRITE (30) 'G92RWF' - WRITE (*, *) 'NWII', NWII - DO K = 1, NWII - WRITE (30) NPII(K), NAKII(K), EII(K), MFII(K) - WRITE (30) PZII(K), (PFII(I,K),I=1,MFII(K)), (QFII(I,K),I=1,MFII(K)) - WRITE (30) (R(I),I=1,MFII(K)) - END DO - - CLOSE(30) - - J = INDEX(NAME(2),' ') + 'UNKNOWN', POSITION='asis') + + WRITE (30) 'G92RWF' + WRITE (*, *) 'NWII', NWII + DO K = 1, NWII + WRITE (30) NPII(K), NAKII(K), EII(K), MFII(K) + WRITE (30) PZII(K), (PFII(I,K),I=1,MFII(K)), (QFII(I,K),I=1,MFII(K)) + WRITE (30) (R(I),I=1,MFII(K)) + END DO + + CLOSE(30) + + J = INDEX(NAME(2),' ') OPEN(UNIT=30, FILE=NAME(2)(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - - WRITE (30) 'G92RWF' - WRITE (*, *) 'NWFF', NWFF - DO K = 1, NWFF - WRITE (30) NPFF(K), NAKFF(K), EFF(K), MFFF(K) - WRITE (30) PZFF(K),(PFFF(I,K),I=1,MFFF(K)),(QFFF(I,K),I=1,MFFF(K)) - WRITE (30) (R(I),I=1,MFFF(K)) - END DO - - CLOSE(30) - - RETURN - END SUBROUTINE RADFILE + 'UNKNOWN', POSITION='asis') + + WRITE (30) 'G92RWF' + WRITE (*, *) 'NWFF', NWFF + DO K = 1, NWFF + WRITE (30) NPFF(K), NAKFF(K), EFF(K), MFFF(K) + WRITE (30) PZFF(K),(PFFF(I,K),I=1,MFFF(K)),(QFFF(I,K),I=1,MFFF(K)) + WRITE (30) (R(I),I=1,MFFF(K)) + END DO + + CLOSE(30) + + RETURN + END SUBROUTINE RADFILE diff --git a/src/appl/rbiotransform90/radfile_I.f90 b/src/appl/rbiotransform90/radfile_I.f90 index 826013b47..b49370b1c 100644 --- a/src/appl/rbiotransform90/radfile_I.f90 +++ b/src/appl/rbiotransform90/radfile_I.f90 @@ -1,10 +1,10 @@ - MODULE radfile_I + MODULE radfile_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE radfile (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE radfile (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/radpar.f90 b/src/appl/rbiotransform90/radpar.f90 index deac00935..7b3749899 100644 --- a/src/appl/rbiotransform90/radpar.f90 +++ b/src/appl/rbiotransform90/radpar.f90 @@ -1,18 +1,18 @@ !*********************************************************************** ! * - SUBROUTINE RADPAR + SUBROUTINE RADPAR ! * ! This subroutine sets the parameters controlling the radial grid * ! * ! Last revision: June 1996 * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE def_C, ONLY: c, cvac, z, accy USE default_C @@ -21,66 +21,66 @@ SUBROUTINE RADPAR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: YES - CHARACTER :: ANSWER + LOGICAL :: YES + CHARACTER :: ANSWER !----------------------------------------------- ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !cff .. Should be Z-dependent RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF - ENDIF + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! - - IF (NDEF /= 0) THEN - WRITE (6, *) 'The physical speed of light in' - WRITE (6, *) ' atomic units is', CVAC, ';' - WRITE (6, *) ' revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter the revised value:' - READ (5, *) C - ELSE - C = CVAC - ENDIF - ELSE - C = CVAC - ENDIF - - RETURN - END SUBROUTINE RADPAR + + IF (NDEF /= 0) THEN + WRITE (6, *) 'The physical speed of light in' + WRITE (6, *) ' atomic units is', CVAC, ';' + WRITE (6, *) ' revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter the revised value:' + READ (5, *) C + ELSE + C = CVAC + ENDIF + ELSE + C = CVAC + ENDIF + + RETURN + END SUBROUTINE RADPAR diff --git a/src/appl/rbiotransform90/radpar_I.f90 b/src/appl/rbiotransform90/radpar_I.f90 index cbb14f720..f74cd14ce 100644 --- a/src/appl/rbiotransform90/radpar_I.f90 +++ b/src/appl/rbiotransform90/radpar_I.f90 @@ -1,9 +1,9 @@ - MODULE radpar_I + MODULE radpar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE radpar - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE radpar + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/rintff.f90 b/src/appl/rbiotransform90/rintff.f90 index 8c67418d4..39af9d807 100644 --- a/src/appl/rbiotransform90/rintff.f90 +++ b/src/appl/rbiotransform90/rintff.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) ! * ! The value of RINT is an approximation to: * ! * @@ -16,51 +16,51 @@ REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) ! Written by Farid A Parpia, at Oxford Last updated: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFFF(I),MFFF(J)) + MTP = MIN(MFFF(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PFFF(L,I)*PFFF(L,J) + QFFF(L,I)*QFFF(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PFFF(L,I)*PFFF(L,J) + QFFF(L,I)*QFFF(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - RINTFF = RESULT + CALL QUAD (RESULT) + RINTFF = RESULT ! - RETURN + RETURN ! - END FUNCTION RINTFF + END FUNCTION RINTFF diff --git a/src/appl/rbiotransform90/rintff_I.f90 b/src/appl/rbiotransform90/rintff_I.f90 index 6ece8459b..81427bd85 100644 --- a/src/appl/rbiotransform90/rintff_I.f90 +++ b/src/appl/rbiotransform90/rintff_I.f90 @@ -1,12 +1,12 @@ - MODULE rintff_I + MODULE rintff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rintff (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintff (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/rintii.f90 b/src/appl/rbiotransform90/rintii.f90 index 71d3af7d4..c230046d5 100644 --- a/src/appl/rbiotransform90/rintii.f90 +++ b/src/appl/rbiotransform90/rintii.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) ! * ! The value of RINT is an approximation to: * ! * @@ -16,51 +16,51 @@ REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) ! Written by Farid A Parpia, at Oxford Last updated: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFII(J)) + MTP = MIN(MFII(I),MFII(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PFII(L,I)*PFII(L,J) + QFII(L,I)*QFII(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PFII(L,I)*PFII(L,J) + QFII(L,I)*QFII(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - RINTII = RESULT + CALL QUAD (RESULT) + RINTII = RESULT ! - RETURN + RETURN ! - END FUNCTION RINTII + END FUNCTION RINTII diff --git a/src/appl/rbiotransform90/rintii_I.f90 b/src/appl/rbiotransform90/rintii_I.f90 index dc077337d..fc13eb068 100644 --- a/src/appl/rbiotransform90/rintii_I.f90 +++ b/src/appl/rbiotransform90/rintii_I.f90 @@ -1,12 +1,12 @@ - MODULE rintii_I + MODULE rintii_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rintii (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintii (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/scalve.f90 b/src/appl/rbiotransform90/scalve.f90 index 014e76264..7a9946787 100644 --- a/src/appl/rbiotransform90/scalve.f90 +++ b/src/appl/rbiotransform90/scalve.f90 @@ -4,26 +4,26 @@ ! S C A L V E ! ------------------------------------------------------------------ ! - SUBROUTINE SCALVE(VECTOR, FACTOR, NDIM) + SUBROUTINE SCALVE(VECTOR, FACTOR, NDIM) ! ! CALCULATE SCALAR(FACTOR) TIMES VECTOR -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: FACTOR REAL(DOUBLE), DIMENSION(NDIM), INTENT(INOUT) :: VECTOR !----------------------------------------------- ! - VECTOR(:NDIM) = VECTOR(:NDIM)*FACTOR + VECTOR(:NDIM) = VECTOR(:NDIM)*FACTOR ! - RETURN - END SUBROUTINE SCALVE + RETURN + END SUBROUTINE SCALVE diff --git a/src/appl/rbiotransform90/scalve_I.f90 b/src/appl/rbiotransform90/scalve_I.f90 index 51e7b0550..1727fbcad 100644 --- a/src/appl/rbiotransform90/scalve_I.f90 +++ b/src/appl/rbiotransform90/scalve_I.f90 @@ -1,13 +1,13 @@ - MODULE scalve_I + MODULE scalve_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE scalve (VECTOR, FACTOR, NDIM) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE scalve (VECTOR, FACTOR, NDIM) + USE vast_kind_param,ONLY: DOUBLE REAL(DOUBLE), DIMENSION(NDIM), INTENT(INOUT) :: VECTOR - REAL(DOUBLE), INTENT(IN) :: FACTOR - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/setcslb.f90 b/src/appl/rbiotransform90/setcslb.f90 index 5b30dc25c..c68b7b569 100644 --- a/src/appl/rbiotransform90/setcslb.f90 +++ b/src/appl/rbiotransform90/setcslb.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLB(NAME, NCORE, IGG) + SUBROUTINE SETCSLB(NAME, NCORE, IGG) !----------------------------------------------- ! * ! Open, check, load data from and close the .csl file. This file * @@ -11,57 +11,57 @@ SUBROUTINE SETCSLB(NAME, NCORE, IGG) ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslBio_I + USE openfl_I + USE lodcslBio_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE, IGG - CHARACTER, INTENT(IN) :: NAME*24 + INTEGER :: NCORE, IGG + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR, IOS - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: K, IERR, IOS + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 ! ! ! The .csl file is FORMATTED; it must exist ! - K = INDEX(NAME,' ') - FILNAM = NAME(1:K-1)//'.c' - FORM = 'FORMATTED' - STATUS = 'OLD' - + K = INDEX(NAME,' ') + FILNAM = NAME(1:K-1)//'.c' + FORM = 'FORMATTED' + STATUS = 'OLD' + ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSLBio (NCORE,IGG) + CALL LODCSLBio (NCORE,IGG) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN - END SUBROUTINE SETCSLB + RETURN + END SUBROUTINE SETCSLB diff --git a/src/appl/rbiotransform90/setcslb_I.f90 b/src/appl/rbiotransform90/setcslb_I.f90 index e3d85069f..113de00ad 100644 --- a/src/appl/rbiotransform90/setcslb_I.f90 +++ b/src/appl/rbiotransform90/setcslb_I.f90 @@ -1,11 +1,11 @@ - MODULE setcslb_I + MODULE setcslb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcslb (NAME, NCORE,IGG) - CHARACTER (LEN = 24), INTENT(IN) :: NAME + SUBROUTINE setcslb (NAME, NCORE,IGG) + CHARACTER (LEN = 24), INTENT(IN) :: NAME INTEGER :: NCORE,IGG - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/setvec.f90 b/src/appl/rbiotransform90/setvec.f90 index 21d287c39..904ead68b 100644 --- a/src/appl/rbiotransform90/setvec.f90 +++ b/src/appl/rbiotransform90/setvec.f90 @@ -3,32 +3,32 @@ ! S E T V E C ! ------------------------------------------------------------------ ! - SUBROUTINE SETVEC(VECTOR, VALUE, NDIM) + SUBROUTINE SETVEC(VECTOR, VALUE, NDIM) ! ! VECTOR (*) = VALUE ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: VALUE + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: VALUE REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! - VECTOR(:NDIM) = VALUE + VECTOR(:NDIM) = VALUE ! - RETURN - END SUBROUTINE SETVEC + RETURN + END SUBROUTINE SETVEC diff --git a/src/appl/rbiotransform90/setvec_I.f90 b/src/appl/rbiotransform90/setvec_I.f90 index e906a2008..1fccabb99 100644 --- a/src/appl/rbiotransform90/setvec_I.f90 +++ b/src/appl/rbiotransform90/setvec_I.f90 @@ -1,13 +1,13 @@ - MODULE setvec_I + MODULE setvec_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setvec (VECTOR, VALUE, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR - REAL(DOUBLE), INTENT(IN) :: VALUE - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setvec (VECTOR, VALUE, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR + REAL(DOUBLE), INTENT(IN) :: VALUE + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/tcsl.f90 b/src/appl/rbiotransform90/tcsl.f90 index 5e71a46a0..a59e6a6b4 100644 --- a/src/appl/rbiotransform90/tcsl.f90 +++ b/src/appl/rbiotransform90/tcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TCSL(N) + SUBROUTINE TCSL(N) ! * ! This subroutine transfers data to the initial and final state * ! common blocks * @@ -8,24 +8,24 @@ SUBROUTINE TCSL(N) ! Written by Per Jonsson Last revision: June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: N !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! ! Initial state commons @@ -34,23 +34,23 @@ SUBROUTINE TCSL(N) ! Final state commons ! ! - IF (N == 1) THEN - NCFII = NCF - NWII = NW - NPII(:NW) = NP(:NW) - NAKII(:NW) = NAK(:NW) - NKLII(:NW) = NKL(:NW) - NKJII(:NW) = NKJ(:NW) - NHII(:NW) = NH(:NW) - ELSE - NCFFF = NCF - NWFF = NW - NPFF(:NW) = NP(:NW) - NAKFF(:NW) = NAK(:NW) - NKLFF(:NW) = NKL(:NW) - NKJFF(:NW) = NKJ(:NW) - NHFF(:NW) = NH(:NW) - ENDIF - - RETURN - END SUBROUTINE TCSL + IF (N == 1) THEN + NCFII = NCF + NWII = NW + NPII(:NW) = NP(:NW) + NAKII(:NW) = NAK(:NW) + NKLII(:NW) = NKL(:NW) + NKJII(:NW) = NKJ(:NW) + NHII(:NW) = NH(:NW) + ELSE + NCFFF = NCF + NWFF = NW + NPFF(:NW) = NP(:NW) + NAKFF(:NW) = NAK(:NW) + NKLFF(:NW) = NKL(:NW) + NKJFF(:NW) = NKJ(:NW) + NHFF(:NW) = NH(:NW) + ENDIF + + RETURN + END SUBROUTINE TCSL diff --git a/src/appl/rbiotransform90/tcsl_I.f90 b/src/appl/rbiotransform90/tcsl_I.f90 index 577638d9b..9fb4dd2a9 100644 --- a/src/appl/rbiotransform90/tcsl_I.f90 +++ b/src/appl/rbiotransform90/tcsl_I.f90 @@ -1,10 +1,10 @@ - MODULE tcsl_I + MODULE tcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE tcsl (N) - INTEGER, INTENT(IN) :: N - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE tcsl (N) + INTEGER, INTENT(IN) :: N + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/ti1tv.f90 b/src/appl/rbiotransform90/ti1tv.f90 index e0a2a8604..f36c792c6 100644 --- a/src/appl/rbiotransform90/ti1tv.f90 +++ b/src/appl/rbiotransform90/ti1tv.f90 @@ -29,7 +29,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -65,7 +65,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) NTEST = 000 ! IF(NTEST.GE.10) WRITE(6,*) ' Entering TI1TV' - + CALL SETVEC(CIOUT,0.0D0,NCIV*NCSF) ! !. Obtain address of first coupling coefficient for h(jl,il) : IFIRST @@ -84,7 +84,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) IR = NSHLPP(L,NSHLP(L,I)) IRA = NSHLPP(L,IA) IRB = NSHLPP(L,IB) - + IF (IR.EQ.IRB.AND.IRA.LT.IRB) THEN IF (K.EQ.1) THEN IFIRST = 1 @@ -92,7 +92,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) IFIRST = INTPTR(K-1) + 1 ENDIF NFOUND = INTPTR(K) - IFIRST + 1 - + 15 DO IELMNT = 1, NFOUND RACAH = CNN(IFIRST-1+IELMNT) J = IRA @@ -131,6 +131,6 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) END IF ! IF(NTEST.GE.10) WRITE(6,*) ' LEAVING TI1TV' - + RETURN END diff --git a/src/appl/rbiotransform90/ti1tv_I.f90 b/src/appl/rbiotransform90/ti1tv_I.f90 index ae3050ddf..3ec10302c 100644 --- a/src/appl/rbiotransform90/ti1tv_I.f90 +++ b/src/appl/rbiotransform90/ti1tv_I.f90 @@ -1,6 +1,6 @@ - MODULE ti1tv_I + MODULE ti1tv_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) USE vast_kind_param, ONLY: DOUBLE @@ -9,6 +9,6 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) REAL(DOUBLE), DIMENSION(ncsf, nciv), INTENT(IN) :: ciin REAL(DOUBLE), DIMENSION(nshl), INTENT(IN) :: t REAL(DOUBLE), DIMENSION(ncsf, nciv), INTENT(OUT) :: ciout - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/tiinig.f90 b/src/appl/rbiotransform90/tiinig.f90 index a5182769f..8c4fe2a22 100644 --- a/src/appl/rbiotransform90/tiinig.f90 +++ b/src/appl/rbiotransform90/tiinig.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) + SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! * ! Calculates the action of the operator * ! Const ** E(li,li) on a set of vectors * @@ -26,34 +26,34 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:41:42 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:41:42 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB - USE mcpdata_C + USE mcpdata_C USE sbdat1_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setvec_I - USE wrtmat_I + USE setvec_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCSF - INTEGER :: NCIV - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: L - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), INTENT(IN) :: CONST - REAL(DOUBLE) :: CIIN(NCSF,NCIV) - REAL(DOUBLE) :: CIOUT(NCSF,NCIV) + INTEGER :: NCSF + INTEGER :: NCIV + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: L + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), INTENT(IN) :: CONST + REAL(DOUBLE) :: CIIN(NCSF,NCIV) + REAL(DOUBLE) :: CIOUT(NCSF,NCIV) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- @@ -62,18 +62,18 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NTESTL, NTEST, NFOUND, K, IA, IB, IFIRST, IELMNT, IVAL, ILEFT& - , IVEC - REAL(DOUBLE) :: CONSTN + , IVEC + REAL(DOUBLE) :: CONSTN !----------------------------------------------- ! ! - NTESTL = 0 - NTEST = MAX(NTESTL,NTESTG) - - - IF (NTEST >= 10) WRITE (6, *) ' Entering TIINI' - - CALL SETVEC (CIOUT, 0.0D0, NCSF*NCIV) + NTESTL = 0 + NTEST = MAX(NTESTL,NTESTG) + + + IF (NTEST >= 10) WRITE (6, *) ' Entering TIINI' + + CALL SETVEC (CIOUT, 0.0D0, NCSF*NCIV) ! !. Obtain address of first coupling coefficient for h(il,il) : IFIRST !. Obtain number of coupling coefficient for h(il,il) : NFOUND @@ -82,46 +82,46 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! IVAL : actual RACAH coefficient ! ILEFT = CSF(L) ? ! - NFOUND = 0 + NFOUND = 0 DO K = 1, NINTG - IA = INTGRL(K)/KEY - IB = MOD(INTGRL(K),KEY) - IF (NSHLP(L,I)/=IA .OR. IA/=IB) CYCLE - IF (K == 1) THEN - IFIRST = 1 - ELSE - IFIRST = INTPTR(K - 1) + 1 - ENDIF - NFOUND = INTPTR(K) - IFIRST + 1 - EXIT - END DO - DO IELMNT = 1, NFOUND + IA = INTGRL(K)/KEY + IB = MOD(INTGRL(K),KEY) + IF (NSHLP(L,I)/=IA .OR. IA/=IB) CYCLE + IF (K == 1) THEN + IFIRST = 1 + ELSE + IFIRST = INTPTR(K - 1) + 1 + ENDIF + NFOUND = INTPTR(K) - IFIRST + 1 + EXIT + END DO + DO IELMNT = 1, NFOUND ! Bug 2011-08-18 Per Jonsson IVAL = CNN(IFIRST-1+IELMNT) IVAL = IDNINT(CNN(IFIRST-1+IELMNT)) - CONSTN = CONST**IVAL - ILEFT = JANN(IFIRST - 1 + IELMNT) - CIOUT(ILEFT,:NCIV) = CONSTN*CIIN(ILEFT,:NCIV) - END DO + CONSTN = CONST**IVAL + ILEFT = JANN(IFIRST - 1 + IELMNT) + CIOUT(ILEFT,:NCIV) = CONSTN*CIIN(ILEFT,:NCIV) + END DO ! !. The previous provided us with all ! terms with nonvanishing occupation. ! For terms with vanishing occupation of il, ! just copy coefficients, since (x) ** 0 = 1 ! - WHERE (CIOUT(:NCSF,:NCIV) == 0.0D0) - CIOUT(:NCSF,:NCIV) = CIIN(:NCSF,:NCIV) - END WHERE + WHERE (CIOUT(:NCSF,:NCIV) == 0.0D0) + CIOUT(:NCSF,:NCIV) = CIIN(:NCSF,:NCIV) + END WHERE ! - IF (NTEST >= 100) THEN - WRITE (6, *) - WRITE (6, *) ' Input and output vectors from TIINI I,L', I, L - CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) - CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) - ENDIF + IF (NTEST >= 100) THEN + WRITE (6, *) + WRITE (6, *) ' Input and output vectors from TIINI I,L', I, L + CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) + CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) + ENDIF ! - IF (NTEST >= 10) WRITE (6, *) ' Leaving TIINI' - - RETURN - END SUBROUTINE TIINIG + IF (NTEST >= 10) WRITE (6, *) ' Leaving TIINI' + + RETURN + END SUBROUTINE TIINIG diff --git a/src/appl/rbiotransform90/tiinig_I.f90 b/src/appl/rbiotransform90/tiinig_I.f90 index ed6bd5f31..4f244d31c 100644 --- a/src/appl/rbiotransform90/tiinig_I.f90 +++ b/src/appl/rbiotransform90/tiinig_I.f90 @@ -1,18 +1,18 @@ - MODULE tiinig_I + MODULE tiinig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN - INTEGER, INTENT(IN) :: NCSF - INTEGER, INTENT(IN) :: NCIV - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: L - REAL(DOUBLE), INTENT(IN) :: CONST - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN + INTEGER, INTENT(IN) :: NCSF + INTEGER, INTENT(IN) :: NCIV + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: L + REAL(DOUBLE), INTENT(IN) :: CONST + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/trpmat.f90 b/src/appl/rbiotransform90/trpmat.f90 index 19cc423dc..73e88f693 100644 --- a/src/appl/rbiotransform90/trpmat.f90 +++ b/src/appl/rbiotransform90/trpmat.f90 @@ -3,32 +3,32 @@ ! T R P M A T ! ------------------------------------------------------------------ ! - SUBROUTINE TRPMAT(XIN, NROW, NCOL, XOUT) + SUBROUTINE TRPMAT(XIN, NROW, NCOL, XOUT) ! ! XOUT(I,J) = XIN(J,I) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NROW - INTEGER , INTENT(IN) :: NCOL - REAL(DOUBLE) , INTENT(IN) :: XIN(NROW,NCOL) - REAL(DOUBLE) , INTENT(OUT) :: XOUT(NCOL,NROW) + INTEGER , INTENT(IN) :: NROW + INTEGER , INTENT(IN) :: NCOL + REAL(DOUBLE) , INTENT(IN) :: XIN(NROW,NCOL) + REAL(DOUBLE) , INTENT(OUT) :: XOUT(NCOL,NROW) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IROW, ICOL + INTEGER :: IROW, ICOL !----------------------------------------------- ! - XOUT = TRANSPOSE(XIN) + XOUT = TRANSPOSE(XIN) ! - RETURN - END SUBROUTINE TRPMAT + RETURN + END SUBROUTINE TRPMAT diff --git a/src/appl/rbiotransform90/trpmat_I.f90 b/src/appl/rbiotransform90/trpmat_I.f90 index 4be1977f9..34c7db240 100644 --- a/src/appl/rbiotransform90/trpmat_I.f90 +++ b/src/appl/rbiotransform90/trpmat_I.f90 @@ -1,14 +1,14 @@ - MODULE trpmat_I + MODULE trpmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE trpmat (XIN, NROW, NCOL, XOUT) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NROW,NCOL), INTENT(IN) :: XIN - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - REAL(DOUBLE), DIMENSION(NCOL,NROW), INTENT(OUT) :: XOUT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE trpmat (XIN, NROW, NCOL, XOUT) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NROW,NCOL), INTENT(IN) :: XIN + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + REAL(DOUBLE), DIMENSION(NCOL,NROW), INTENT(OUT) :: XOUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/ulla.f90 b/src/appl/rbiotransform90/ulla.f90 index 895eda4e0..88b3be393 100644 --- a/src/appl/rbiotransform90/ulla.f90 +++ b/src/appl/rbiotransform90/ulla.f90 @@ -3,7 +3,7 @@ ! U L L A ! ------------------------------------------------------------------ ! - SUBROUTINE ULLA(A, U, L, NDIM, SCR) + SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! Obtain U L decomposition of matrix A ! A = U L @@ -12,32 +12,32 @@ SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! Quick and dirty routine, Jeppe Olsen, November 1991 !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lulu_I - USE setvec_I - USE wrtmat_I + USE lulu_I + USE setvec_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) - REAL(DOUBLE) :: U(NDIM,NDIM) - REAL(DOUBLE) :: L(NDIM,NDIM) - REAL(DOUBLE) :: SCR(*) + INTEGER :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) + REAL(DOUBLE) :: U(NDIM,NDIM) + REAL(DOUBLE) :: L(NDIM,NDIM) + REAL(DOUBLE) :: SCR(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KLFREE, KLPAP, I, J, KLL, KLU, IMAX, IMIN, NTEST + INTEGER :: KLFREE, KLPAP, I, J, KLL, KLU, IMAX, IMIN, NTEST !----------------------------------------------- ! ! @@ -50,45 +50,45 @@ SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! 1 : PAP in scr(klPAP) ! - KLFREE = 1 - KLPAP = KLFREE - KLFREE = KLFREE + NDIM**2 + KLFREE = 1 + KLPAP = KLFREE + KLFREE = KLFREE + NDIM**2 ! - DO I = 1, NDIM - SCR(KLPAP-1+I:NDIM*(NDIM-1)+KLPAP-1+I:NDIM) = A(NDIM+1-I,NDIM:1:(-1)) - END DO + DO I = 1, NDIM + SCR(KLPAP-1+I:NDIM*(NDIM-1)+KLPAP-1+I:NDIM) = A(NDIM+1-I,NDIM:1:(-1)) + END DO ! 2 : Lu decompose PAP - KLL = KLFREE - KLFREE = KLFREE + NDIM*(NDIM + 1)/2 + KLL = KLFREE + KLFREE = KLFREE + NDIM*(NDIM + 1)/2 ! - KLU = KLFREE - KLFREE = KLFREE + NDIM*(NDIM + 1)/2 - CALL LULU (SCR(KLPAP), SCR(KLL), SCR(KLU), NDIM) + KLU = KLFREE + KLFREE = KLFREE + NDIM*(NDIM + 1)/2 + CALL LULU (SCR(KLPAP), SCR(KLL), SCR(KLU), NDIM) ! LULU(A,L,U,NDIM) ! Storage modes ! L(I,J) = L(I*(I-1)/2 + J ) ( I .GE. J ) ! U(I,J) = U(J*(J-1)/2 + I ) ( J .GE. I ) ! !. 3 : Obtain U as PLP and L as PUP - CALL SETVEC (U, 0.0D0, NDIM**2) - CALL SETVEC (L, 0.0D0, NDIM**2) + CALL SETVEC (U, 0.0D0, NDIM**2) + CALL SETVEC (L, 0.0D0, NDIM**2) ! - DO IMAX = 1, NDIM - DO IMIN = 1, IMAX + DO IMAX = 1, NDIM + DO IMIN = 1, IMAX U(IMIN,IMAX) = SCR(KLL-1+(NDIM+1-IMIN)*(NDIM+1-IMIN-1)/2+(NDIM+1-& - IMAX)) + IMAX)) L(IMAX,IMIN) = SCR(KLU-1+(NDIM+1-IMIN)*(NDIM+1-IMIN-1)/2+(NDIM+1-& - IMAX)) - END DO - END DO + IMAX)) + END DO + END DO ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' U and L from Ulla ' - CALL WRTMAT (U, NDIM, NDIM, NDIM, NDIM) - CALL WRTMAT (L, NDIM, NDIM, NDIM, NDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' U and L from Ulla ' + CALL WRTMAT (U, NDIM, NDIM, NDIM, NDIM) + CALL WRTMAT (L, NDIM, NDIM, NDIM, NDIM) + ENDIF ! - - RETURN - END SUBROUTINE ULLA + + RETURN + END SUBROUTINE ULLA diff --git a/src/appl/rbiotransform90/ulla_I.f90 b/src/appl/rbiotransform90/ulla_I.f90 index 36a0b74a2..187c87050 100644 --- a/src/appl/rbiotransform90/ulla_I.f90 +++ b/src/appl/rbiotransform90/ulla_I.f90 @@ -1,15 +1,15 @@ - MODULE ulla_I + MODULE ulla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ulla (A, U, L, NDIM, SCR) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: U - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: L - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ulla (A, U, L, NDIM, SCR) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: U + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: L + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/vecsum.f90 b/src/appl/rbiotransform90/vecsum.f90 index 4a59e9c46..6e4c96439 100644 --- a/src/appl/rbiotransform90/vecsum.f90 +++ b/src/appl/rbiotransform90/vecsum.f90 @@ -3,46 +3,46 @@ ! V E C S U M ! ------------------------------------------------------------------ ! - SUBROUTINE VECSUM(C, A, B, FACA, FACB, NDIM) + SUBROUTINE VECSUM(C, A, B, FACA, FACB, NDIM) ! ! CACLULATE THE VECTOR C(I)=FACA*A(I)+FACB*B(I) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: FACA - REAL(DOUBLE), INTENT(IN) :: FACB + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: FACA + REAL(DOUBLE), INTENT(IN) :: FACB REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: A REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: S + INTEGER :: I + REAL(DOUBLE) :: S !----------------------------------------------- ! - IF (FACA/=0.0D0 .AND. FACB/=0.0D0) THEN - C(:NDIM) = FACA*A(:NDIM) + FACB*B(:NDIM) + IF (FACA/=0.0D0 .AND. FACB/=0.0D0) THEN + C(:NDIM) = FACA*A(:NDIM) + FACB*B(:NDIM) ! - ELSE IF (FACA==0.0D0 .AND. FACB/=0.0D0) THEN - C(:NDIM) = FACB*B(:NDIM) + ELSE IF (FACA==0.0D0 .AND. FACB/=0.0D0) THEN + C(:NDIM) = FACB*B(:NDIM) ! - ELSE IF (FACA/=0.0D0 .AND. FACB==0.0D0) THEN - C(:NDIM) = FACA*A(:NDIM) + ELSE IF (FACA/=0.0D0 .AND. FACB==0.0D0) THEN + C(:NDIM) = FACA*A(:NDIM) ! - ELSE IF (FACA==0.0D0 .AND. FACB==0.0D0) THEN - C(:NDIM) = 0.0D0 - ENDIF + ELSE IF (FACA==0.0D0 .AND. FACB==0.0D0) THEN + C(:NDIM) = 0.0D0 + ENDIF ! - RETURN - END SUBROUTINE VECSUM + RETURN + END SUBROUTINE VECSUM diff --git a/src/appl/rbiotransform90/vecsum_I.f90 b/src/appl/rbiotransform90/vecsum_I.f90 index 8e6261b13..b1918bf98 100644 --- a/src/appl/rbiotransform90/vecsum_I.f90 +++ b/src/appl/rbiotransform90/vecsum_I.f90 @@ -1,16 +1,16 @@ - MODULE vecsum_I + MODULE vecsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vecsum (C, A, B, FACA, FACB, NDIM) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE vecsum (C, A, B, FACA, FACB, NDIM) + USE vast_kind_param,ONLY: DOUBLE REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: A REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: C - REAL(DOUBLE), INTENT(IN) :: FACA - REAL(DOUBLE), INTENT(IN) :: FACB - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: FACA + REAL(DOUBLE), INTENT(IN) :: FACB + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90/wrtmat.f90 b/src/appl/rbiotransform90/wrtmat.f90 index 83742807e..d37e1d3c9 100644 --- a/src/appl/rbiotransform90/wrtmat.f90 +++ b/src/appl/rbiotransform90/wrtmat.f90 @@ -1,35 +1,35 @@ !*********************************************************************** ! * - SUBROUTINE WRTMAT(A, NROW, NCOL, NMROW, NMCOL) + SUBROUTINE WRTMAT(A, NROW, NCOL, NMROW, NMCOL) ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - INTEGER, INTENT(IN) :: NMROW - INTEGER, INTENT(IN) :: NMCOL - REAL(DOUBLE), INTENT(IN) :: A(NMROW,NMCOL) + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + INTEGER, INTENT(IN) :: NMROW + INTEGER, INTENT(IN) :: NMCOL + REAL(DOUBLE), INTENT(IN) :: A(NMROW,NMCOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- - - DO I = 1, NROW - WRITE (6, 1010) I, (A(I,J),J=1,NCOL) - END DO - - 1010 FORMAT('0',I5,2X,4(1X,E14.7),/,(' ',7X,4(1X,E14.7))) - - RETURN - END SUBROUTINE WRTMAT + + DO I = 1, NROW + WRITE (6, 1010) I, (A(I,J),J=1,NCOL) + END DO + + 1010 FORMAT('0',I5,2X,4(1X,E14.7),/,(' ',7X,4(1X,E14.7))) + + RETURN + END SUBROUTINE WRTMAT diff --git a/src/appl/rbiotransform90/wrtmat_I.f90 b/src/appl/rbiotransform90/wrtmat_I.f90 index c4cb53902..103d9e97b 100644 --- a/src/appl/rbiotransform90/wrtmat_I.f90 +++ b/src/appl/rbiotransform90/wrtmat_I.f90 @@ -1,16 +1,16 @@ - MODULE wrtmat_I + MODULE wrtmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE wrtmat (A, NROW, NCOL, NMROW, NMCOL) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NMROW,NMCOL), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - INTEGER, INTENT(IN) :: NMROW - INTEGER, INTENT(IN) :: NMCOL + SUBROUTINE wrtmat (A, NROW, NCOL, NMROW, NMCOL) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NMROW,NMCOL), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + INTEGER, INTENT(IN) :: NMROW + INTEGER, INTENT(IN) :: NMCOL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/Makefile b/src/appl/rbiotransform90_mpi/Makefile old mode 100755 new mode 100644 index 0702097fe..77a5bc24e --- a/src/appl/rbiotransform90_mpi/Makefile +++ b/src/appl/rbiotransform90_mpi/Makefile @@ -44,5 +44,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - - diff --git a/src/appl/rbiotransform90_mpi/angdatampi.f90 b/src/appl/rbiotransform90_mpi/angdatampi.f90 index 8ab1ac610..23128f089 100644 --- a/src/appl/rbiotransform90_mpi/angdatampi.f90 +++ b/src/appl/rbiotransform90_mpi/angdatampi.f90 @@ -1,17 +1,17 @@ !*********************************************************************** ! * - SUBROUTINE ANGDATA(NAME, AVAIL, KAMAX) + SUBROUTINE ANGDATA(NAME, AVAIL, KAMAX) ! * ! Checks if the angular file name.T is available and appropriate * ! * ! Written by Per Jonsson 6 March 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE orb_C, ONLY: NCF, NW USE mpi_C @@ -19,40 +19,40 @@ SUBROUTINE ANGDATA(NAME, AVAIL, KAMAX) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: KAMAX - LOGICAL, INTENT(OUT) :: AVAIL - CHARACTER, INTENT(INOUT) :: NAME*24 + INTEGER, INTENT(IN) :: KAMAX + LOGICAL, INTENT(OUT) :: AVAIL + CHARACTER, INTENT(INOUT) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J,NF,NCFD,NWD,KAMAXD,nprocsD,myidD - LOGICAL :: FOUND + LOGICAL :: FOUND !----------------------------------------------- ! - J = INDEX(NAME,' ') - INQUIRE(FILE=NAME(1:J-1)//'.TB', EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (6, *) ' Angular file not available' - AVAIL = .FALSE. - RETURN - ELSE + J = INDEX(NAME,' ') + INQUIRE(FILE=NAME(1:J-1)//'.TB', EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (6, *) ' Angular file not available' + AVAIL = .FALSE. + RETURN + ELSE ! ! Open the file and check if it is appropriate for the present case ! - NF = 200 + NF = 200 OPEN(UNIT=NF, FILE=NAME(1:J-1)//'.TB', STATUS='OLD', FORM=& - 'UNFORMATTED', POSITION='asis') - REWIND (NF) + 'UNFORMATTED', POSITION='asis') + REWIND (NF) READ (NF) NCFD,NWD,KAMAXD,nprocsD,myidD IF (.NOT.(NCFD==NCF .AND. NWD==NW .AND. KAMAXD==KAMAX & .AND.nprocsD==nprocs.AND.myidD==myid)) THEN - WRITE (6, *) ' Angular file not appropriate' - AVAIL = .FALSE. - RETURN - ELSE - WRITE (6, *) ' Angular data read from file' - AVAIL = .TRUE. - ENDIF - ENDIF - RETURN + WRITE (6, *) ' Angular file not appropriate' + AVAIL = .FALSE. + RETURN + ELSE + WRITE (6, *) ' Angular data read from file' + AVAIL = .TRUE. + ENDIF + ENDIF + RETURN END SUBROUTINE ANGDATA diff --git a/src/appl/rbiotransform90_mpi/angdatampi_I.f90 b/src/appl/rbiotransform90_mpi/angdatampi_I.f90 index f9eb31e42..324cb5ac9 100644 --- a/src/appl/rbiotransform90_mpi/angdatampi_I.f90 +++ b/src/appl/rbiotransform90_mpi/angdatampi_I.f90 @@ -1,12 +1,12 @@ - MODULE angdata_I + MODULE angdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE angdata (NAME, AVAIL, KAMAX) - CHARACTER (LEN = 24), INTENT(INOUT) :: NAME - LOGICAL, INTENT(OUT) :: AVAIL - INTEGER, INTENT(IN) :: KAMAX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE angdata (NAME, AVAIL, KAMAX) + CHARACTER (LEN = 24), INTENT(INOUT) :: NAME + LOGICAL, INTENT(OUT) :: AVAIL + INTEGER, INTENT(IN) :: KAMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/biotr1.f90 b/src/appl/rbiotransform90_mpi/biotr1.f90 index 8e7e5ce1f..b81b9453c 100644 --- a/src/appl/rbiotransform90_mpi/biotr1.f90 +++ b/src/appl/rbiotransform90_mpi/biotr1.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & - NGRID, MXL, SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) + NGRID, MXL, SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) ! * ! Generate Matrices for rotating radial functions and * ! for counter rotating CI coefficients * @@ -58,34 +58,34 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & ! occupied shells ( inactive+active) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ifnmnx_I - USE ielsum_I -! USE gets_I -! USE wrtmat_I -! USE copvec_I -! USE invmat_I -! USE ulla_I -! USE trpmat_I -! USE matml4_I -! USE scalve_I -! USE setvec_I -! USE pamtmt_I + USE ifnmnx_I + USE ielsum_I +! USE gets_I +! USE wrtmat_I +! USE copvec_I +! USE invmat_I +! USE ulla_I +! USE trpmat_I +! USE matml4_I +! USE scalve_I +! USE setvec_I +! USE pamtmt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER, INTENT(IN) :: NGRID, MXL - INTEGER, INTENT(IN) :: LSCR, NTESTG + INTEGER, INTENT(IN) :: LSCR, NTESTG INTEGER, DIMENSION(MXL) :: NLI, NINSHLI, NLF, NINSHLF ! The following have dimensions (NGRID:*) !GG REAL(DOUBLE), DIMENSION(:,:), pointer :: PI, QI, PF, QF @@ -104,125 +104,125 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & NLTF, KFREE, KLPI, KLPF, KLPIF, KLSTOT, KLSIF, KLSIFI, & KLCI, KLCF, KLSCR, L, IIOFF, IFOFF, NI, NF, NIFMN, III,& JJJ, KLPMX, KLPMN, NMX, NMN, KLCMX, KLCMN, NDIFF, J, & - KLTI, I, KLTF - REAL(DOUBLE) :: TII, TIII + KLTI, I, KLTF + REAL(DOUBLE) :: TII, TIII !----------------------------------------------- ! - NTESTL = 0 - NTEST = MAX(NTESTL,NTESTG) - IF (NTEST >= 1) THEN - WRITE (6, *) - WRITE (6, *) ' *************************' - WRITE (6, *) ' * Entering BIOTR1 *' - WRITE (6, *) ' *************************' - WRITE (6, *) - ENDIF + NTESTL = 0 + NTEST = MAX(NTESTL,NTESTG) + IF (NTEST >= 1) THEN + WRITE (6, *) + WRITE (6, *) ' *************************' + WRITE (6, *) ' * Entering BIOTR1 *' + WRITE (6, *) ' *************************' + WRITE (6, *) + ENDIF ! !. Scratch should at least be of length ! - ILI = 1 - ILF = 1 + ILI = 1 + ILF = 1 ! !. Largest number of shells of a given symmetry ! - NLIMX = IFNMNX(NLI,MXL,1) - NLFMX = IFNMNX(NLF,MXL,1) - NLIFMX = MAX(NLIMX,NLFMX) + NLIMX = IFNMNX(NLI,MXL,1) + NLFMX = IFNMNX(NLF,MXL,1) + NLIFMX = MAX(NLIMX,NLFMX) IF (NTEST >= 10) WRITE (6, *) ' NLIMX,NLFMX NLIFMX ', NLIMX, NLFMX, & - NLIFMX + NLIFMX ! !. Total numner of shells ! - NLTI = IELSUM(NLI,MXL) - NLTF = IELSUM(NLF,MXL) - IF (NTEST >= 10) WRITE (6, *) ' NLTI NLTF', NLTI, NLTF + NLTI = IELSUM(NLI,MXL) + NLTF = IELSUM(NLF,MXL) + IF (NTEST >= 10) WRITE (6, *) ' NLTI NLTF', NLTI, NLTF ! ! Scratch space for orbital rotations - KFREE = 1 + KFREE = 1 ! - KLPI = KFREE - KFREE = KFREE + NLIMX*NGRID -! WRITE (6, *) ' In biotrn: KLPI = ', KLPI -! WRITE (6, *) ' KFREE = ', KFREE + KLPI = KFREE + KFREE = KFREE + NLIMX*NGRID +! WRITE (6, *) ' In biotrn: KLPI = ', KLPI +! WRITE (6, *) ' KFREE = ', KFREE ! - KLPF = KFREE - KFREE = KFREE + NLFMX*NGRID -! WRITE (6, *) ' In biotrn: KLPF = ', KLPF -! WRITE (6, *) ' KFREE = ', KFREE + KLPF = KFREE + KFREE = KFREE + NLFMX*NGRID +! WRITE (6, *) ' In biotrn: KLPF = ', KLPF +! WRITE (6, *) ' KFREE = ', KFREE ! - KLPIF = KFREE - KFREE = KFREE + NLIFMX*NGRID -! WRITE (6, *) ' In biotrn: KLPIF = ', KLPIF -! WRITE (6, *) ' KFREE = ', KFREE + KLPIF = KFREE + KFREE = KFREE + NLIFMX*NGRID +! WRITE (6, *) ' In biotrn: KLPIF = ', KLPIF +! WRITE (6, *) ' KFREE = ', KFREE ! !. Total overlap matrix ! - KLSTOT = KFREE - KFREE = KFREE + NLTI*NLTF -! WRITE (6, *) ' In biotrn: KLSTOT = ', KLSTOT -! WRITE (6, *) ' KFREE = ', KFREE -! - KLSIF = KFREE - KFREE = KFREE + NLIFMX**2 -! WRITE (6, *) ' In biotrn: KLSIF = ', KLSIF -! WRITE (6, *) ' KFREE = ', KFREE -! - KLSIFI = KFREE - KFREE = KFREE + NLIFMX**2 -! WRITE (6, *) ' In biotrn: KLSIFI = ', KLSIFI -! WRITE (6, *) ' KFREE = ', KFREE -! - KLCI = KFREE - KFREE = KFREE + NLIFMX**2 -! WRITE (6, *) ' In biotrn: KLCI = ', KLCI -! WRITE (6, *) ' KFREE = ', KFREE -! - KLCF = KFREE - KFREE = KFREE + NLIFMX**2 -! WRITE (6, *) ' In biotrn: KLCF = ', KLCF -! WRITE (6, *) ' KFREE = ', KFREE -! - KLSCR = KFREE - KFREE = KFREE + NLIFMX**2 + NLIFMX*(NLIFMX + 1) -! WRITE (6, *) ' In biotrn: KLSCR = ', KLSCR -! WRITE (6, *) ' KFREE = ', KFREE -! WRITE (6, *) ' => FREE = ', KFREE + KLSTOT = KFREE + KFREE = KFREE + NLTI*NLTF +! WRITE (6, *) ' In biotrn: KLSTOT = ', KLSTOT +! WRITE (6, *) ' KFREE = ', KFREE +! + KLSIF = KFREE + KFREE = KFREE + NLIFMX**2 +! WRITE (6, *) ' In biotrn: KLSIF = ', KLSIF +! WRITE (6, *) ' KFREE = ', KFREE +! + KLSIFI = KFREE + KFREE = KFREE + NLIFMX**2 +! WRITE (6, *) ' In biotrn: KLSIFI = ', KLSIFI +! WRITE (6, *) ' KFREE = ', KFREE +! + KLCI = KFREE + KFREE = KFREE + NLIFMX**2 +! WRITE (6, *) ' In biotrn: KLCI = ', KLCI +! WRITE (6, *) ' KFREE = ', KFREE +! + KLCF = KFREE + KFREE = KFREE + NLIFMX**2 +! WRITE (6, *) ' In biotrn: KLCF = ', KLCF +! WRITE (6, *) ' KFREE = ', KFREE +! + KLSCR = KFREE + KFREE = KFREE + NLIFMX**2 + NLIFMX*(NLIFMX + 1) +! WRITE (6, *) ' In biotrn: KLSCR = ', KLSCR +! WRITE (6, *) ' KFREE = ', KFREE +! WRITE (6, *) ' => FREE = ', KFREE ! !. Check length of scratch ! - IF (LSCR <= KFREE - 1) THEN - WRITE (6,*)' BIOTR1 in trouble ! ' + IF (LSCR <= KFREE - 1) THEN + WRITE (6,*)' BIOTR1 in trouble ! ' WRITE (6,*)' Increase dimension of scratch before call to BIOTR1' WRITE (6,*)' Current and required length (LSCR,KFREE-1)', LSCR, & - KFREE - 1 - STOP 'Increase LWORK before call to BIOTR1' - ENDIF + KFREE - 1 + STOP 'Increase LWORK before call to BIOTR1' + ENDIF ! !. Obtain overlap matrix ! - CALL GETS (SCR(KLSTOT), NLTI,NLTF) - - DO L = 1, MXL - IF (NTEST >= 5) THEN - WRITE (6, *) ' L = ', L - WRITE (6, *) ' Orbital rotation...' - ENDIF + CALL GETS (SCR(KLSTOT), NLTI,NLTF) + + DO L = 1, MXL + IF (NTEST >= 5) THEN + WRITE (6, *) ' L = ', L + WRITE (6, *) ' Orbital rotation...' + ENDIF ! !. Offsets for given L in shell matrices ! - IF (L == 1) THEN - IIOFF = 1 - IFOFF = 1 - ELSE - IIOFF = IIOFF + NLI(L-1)**2 - IFOFF = IFOFF + NLF(L-1)**2 - ENDIF - IF (NTEST >= 1) THEN - WRITE (6, *) + IF (L == 1) THEN + IIOFF = 1 + IFOFF = 1 + ELSE + IIOFF = IIOFF + NLI(L-1)**2 + IFOFF = IFOFF + NLF(L-1)**2 + ENDIF + IF (NTEST >= 1) THEN + WRITE (6, *) WRITE (6, *) & ' BIOTRN : Information on transformations of shells with L =',L - WRITE (6, *) - ENDIF + WRITE (6, *) + ENDIF ! ! ========================================================= ! 1 : Obtain Biorthogonal forms of initial and final shells @@ -253,220 +253,220 @@ SUBROUTINE BIOTR1(PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, & ! ! With Y = -S-1*X ! - NI = NLI(L) - NF = NLF(L) + NI = NLI(L) + NF = NLF(L) ! !.1.1 : Obtain shells of given L in proper order for ! biorthogonal treatment ! - IF (L == 1) THEN - ILI = 1 - ILF = 1 - ELSE - ILI = ILI + NLI(L-1) - ILF = ILF + NLF(L-1) - ENDIF - + IF (L == 1) THEN + ILI = 1 + ILF = 1 + ELSE + ILI = ILI + NLI(L-1) + ILF = ILF + NLF(L-1) + ENDIF + ! ! 1.2 obtain biorthogonal of the first min(ni,nf) shells ! - NIFMN = MIN(NI,NF) + NIFMN = MIN(NI,NF) ! !. Overlap matrix SIF = Integral (PI(I)*PF(J)) ! !ww Per change to support cases like 3s2p1d 3s2p. The belonging endif !ww Is just at the end - - IF (NIFMN <= 0) CYCLE - - DO III = 1, NIFMN - DO JJJ = 1, NIFMN + + IF (NIFMN <= 0) CYCLE + + DO III = 1, NIFMN + DO JJJ = 1, NIFMN SCR(KLSIF+(JJJ-1)*NIFMN+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-1)*NLTI& - +III+ILI-1) - END DO - END DO - IF (NTEST >= 15) THEN - WRITE (6, *) ' Overlap matrix ' - CALL WRTMAT (SCR(KLSIF), NIFMN, NIFMN, NIFMN, NIFMN) - ENDIF + +III+ILI-1) + END DO + END DO + IF (NTEST >= 15) THEN + WRITE (6, *) ' Overlap matrix ' + CALL WRTMAT (SCR(KLSIF), NIFMN, NIFMN, NIFMN, NIFMN) + ENDIF ! ! Obtain upper triangular CI and CF so CI(T) S CF = 1 ! or CF CI(T) = S-1, which corresponds to an UL decomposition ! !. Invert S ! - CALL COPVEC (SCR(KLSIF), SCR(KLSIFI), NIFMN**2) - CALL INVMAT (SCR(KLSIFI), SCR(KLCI), NIFMN, NIFMN) - + CALL COPVEC (SCR(KLSIF), SCR(KLSIFI), NIFMN**2) + CALL INVMAT (SCR(KLSIFI), SCR(KLCI), NIFMN, NIFMN) + !. UL decompose - CALL COPVEC (SCR(KLSIFI), SCR(KLSIF), NIFMN**2) + CALL COPVEC (SCR(KLSIFI), SCR(KLSIF), NIFMN**2) CALL ULLA (SCR(KLSIF), SCR(KLCF), SCR(KLCI), NIFMN, SCR(KLSCR)) - CALL TRPMAT (SCR(KLCI), NIFMN, NIFMN, SCR(KLSCR)) - CALL COPVEC (SCR(KLSCR), SCR(KLCI), NIFMN**2) + CALL TRPMAT (SCR(KLCI), NIFMN, NIFMN, SCR(KLSCR)) + CALL COPVEC (SCR(KLSCR), SCR(KLCI), NIFMN**2) ! !. The transformation matrix between the first NIFMX !. shells is now known, biorthogonalize remaining orbitals ! - IF (NI/=NF .AND. NI/=0 .AND. NF/=0) THEN - IF (NI > NF) THEN - KLPMX = KLPI - KLPMN = KLPF - NMX = NI - NMN = NF - KLCMX = KLCI - KLCMN = KLCF - ELSE - KLPMX = KLPF - KLPMN = KLPI - NMX = NF - NMN = NI - KLCMX = KLCF - KLCMN = KLCI - ENDIF - NDIFF = NMX - NMN + IF (NI/=NF .AND. NI/=0 .AND. NF/=0) THEN + IF (NI > NF) THEN + KLPMX = KLPI + KLPMN = KLPF + NMX = NI + NMN = NF + KLCMX = KLCI + KLCMN = KLCF + ELSE + KLPMX = KLPF + KLPMN = KLPI + NMX = NF + NMN = NI + KLCMX = KLCF + KLCMN = KLCI + ENDIF + NDIFF = NMX - NMN ! ! Y = -S-1 * X !. overlap X between remaining orbitals and the other set ! - IF (NI > NF) THEN + IF (NI > NF) THEN ! ! I columns F rows ! - DO III = NMN + 1, NMX - DO JJJ = 1, NF + DO III = NMN + 1, NMX + DO JJJ = 1, NF SCR(KLSIF+(III-NMN-1)*NF+JJJ-1) = SCR(KLSTOT-1+(JJJ+ILF-1-& - 1)*NLTI+III+ILI-1) - END DO - END DO - ELSE IF (NF > NI) THEN + 1)*NLTI+III+ILI-1) + END DO + END DO + ELSE IF (NF > NI) THEN ! F columns I rows - DO JJJ = NMN + 1, NMX - DO III = 1, NI + DO JJJ = NMN + 1, NMX + DO III = 1, NI SCR(KLSIF+(JJJ-NMN-1)*NI+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-& - 1)*NLTI+III+ILI-1) - END DO - END DO - ENDIF -! - IF (NI > NF) THEN - CALL TRPMAT (SCR(KLSIFI), NMN, NMN, SCR(KLSCR)) - CALL COPVEC (SCR(KLSCR), SCR(KLSIFI), NMN**2) - ENDIF + 1)*NLTI+III+ILI-1) + END DO + END DO + ENDIF +! + IF (NI > NF) THEN + CALL TRPMAT (SCR(KLSIFI), NMN, NMN, SCR(KLSCR)) + CALL COPVEC (SCR(KLSCR), SCR(KLSIFI), NMN**2) + ENDIF CALL MATML4 (SCR(KLSCR), SCR(KLSIFI), SCR(KLSIF), NMN, NDIFF, NMN, & - NMN, NMN, NDIFF, 0) - CALL SCALVE (SCR(KLSCR), -1.0D0, NMN*NDIFF) - CALL COPVEC (SCR(KLSCR), SCR(KLSIF), NMN*NDIFF) + NMN, NMN, NDIFF, 0) + CALL SCALVE (SCR(KLSCR), -1.0D0, NMN*NDIFF) + CALL COPVEC (SCR(KLSCR), SCR(KLSIF), NMN*NDIFF) ! ! Construct complete CMX ! - CALL SETVEC (SCR(KLSCR), 0.0D0, NMX**2) - DO J = 1, NMX - IF (J <= NIFMN) THEN + CALL SETVEC (SCR(KLSCR), 0.0D0, NMX**2) + DO J = 1, NMX + IF (J <= NIFMN) THEN CALL COPVEC (SCR(KLCMX+(J-1)*NIFMN), SCR(KLSCR+(J-1)*NMX), & - NMN) - ELSE + NMN) + ELSE CALL COPVEC (SCR(KLSIF+(J-NMN-1)*NMN), SCR(KLSCR+(J-1)*NMX), & - NMN) - SCR(KLSCR-1+(J-1)*NMX+J) = 1.0D0 - ENDIF - END DO + NMN) + SCR(KLSCR-1+(J-1)*NMX+J) = 1.0D0 + ENDIF + END DO ! - CALL COPVEC (SCR(KLSCR), SCR(KLCMX), NMX**2) - ENDIF + CALL COPVEC (SCR(KLSCR), SCR(KLCMX), NMX**2) + ENDIF !ww Pertest ! ENDIF ! !. The two upper triangular matrices CI and CF are now known !. Transfer to permanent arrays ! - CALL COPVEC (SCR(KLCI), CISHL(IIOFF), NI**2) - CALL COPVEC (SCR(KLCF), CFSHL(IFOFF), NF**2) + CALL COPVEC (SCR(KLCI), CISHL(IIOFF), NI**2) + CALL COPVEC (SCR(KLCF), CFSHL(IFOFF), NF**2) ! !. Rotate the large component of the shells ! - CALL COPVEC (PI(1,ILI), SCR(KLPI), NI*NGRID) - CALL COPVEC (PF(1,ILF), SCR(KLPF), NF*NGRID) + CALL COPVEC (PI(1,ILI), SCR(KLPI), NI*NGRID) + CALL COPVEC (PF(1,ILF), SCR(KLPF), NF*NGRID) ! -! WRITE (*, *) 'Transformation matrices initial' -! CALL WRTMAT (SCR(KLCI), NI, NI, NI, NI) +! WRITE (*, *) 'Transformation matrices initial' +! CALL WRTMAT (SCR(KLCI), NI, NI, NI, NI) CALL MATML4 (SCR(KLPIF), SCR(KLPI), SCR(KLCI), NGRID, NI, NGRID, NI, & - NI, NI, 0) - CALL COPVEC (SCR(KLPIF), PI(1,ILI), NI*NGRID) -! WRITE (*, *) 'Transformation matrices final' -! CALL WRTMAT (SCR(KLCF), NF, NF, NF, NF) + NI, NI, 0) + CALL COPVEC (SCR(KLPIF), PI(1,ILI), NI*NGRID) +! WRITE (*, *) 'Transformation matrices final' +! CALL WRTMAT (SCR(KLCF), NF, NF, NF, NF) CALL MATML4 (SCR(KLPIF), SCR(KLPF), SCR(KLCF), NGRID, NF, NGRID, NF, & - NF, NF, 0) - CALL COPVEC (SCR(KLPIF), PF(1,ILF), NF*NGRID) + NF, NF, 0) + CALL COPVEC (SCR(KLPIF), PF(1,ILF), NF*NGRID) ! !. Rotate the small component of the shells ! - CALL COPVEC (QI(1,ILI), SCR(KLPI), NI*NGRID) - CALL COPVEC (QF(1,ILF), SCR(KLPF), NF*NGRID) + CALL COPVEC (QI(1,ILI), SCR(KLPI), NI*NGRID) + CALL COPVEC (QF(1,ILF), SCR(KLPF), NF*NGRID) ! CALL MATML4 (SCR(KLPIF), SCR(KLPI), SCR(KLCI), NGRID, NI, NGRID, NI, & - NI, NI, 0) - CALL COPVEC (SCR(KLPIF), QI(1,ILI), NI*NGRID) + NI, NI, 0) + CALL COPVEC (SCR(KLPIF), QI(1,ILI), NI*NGRID) CALL MATML4 (SCR(KLPIF), SCR(KLPF), SCR(KLCF), NGRID, NF, NGRID, NF, & - NF, NF, 0) - CALL COPVEC (SCR(KLPIF), QF(1,ILF), NF*NGRID) + NF, NF, 0) + CALL COPVEC (SCR(KLPIF), QF(1,ILF), NF*NGRID) ! - IF (NTEST >= 1) THEN - WRITE (6, *) ' Test of overlap of biorthonormal functions' + IF (NTEST >= 1) THEN + WRITE (6, *) ' Test of overlap of biorthonormal functions' ! F columns I rows - DO JJJ = 1, NF - DO III = 1, NI + DO JJJ = 1, NF + DO III = 1, NI SCR(KLSIF+(JJJ-1)*NI+III-1) = SCR(KLSTOT-1+(JJJ+ILF-1-1)*NLTI& - +III+ILI-1) - END DO - END DO + +III+ILI-1) + END DO + END DO CALL MATML4 (SCR(KLSCR), SCR(KLCI), SCR(KLSIF), NI, NF, NI, NI, NI& - , NF, 1) + , NF, 1) CALL MATML4 (SCR(KLSIF), SCR(KLSCR), SCR(KLCF), NI, NF, NI, NF, NF& - , NF, 0) + , NF, 0) WRITE (6, *) & - ' new overlap matrix ( should be 1 on diag, 0 elsewhere )' - CALL WRTMAT (SCR(KLSIF), NI, NF, NI, NF) - ENDIF - - IF (NTEST >= 1) THEN - WRITE (6, *) - WRITE (6, *) ' Orbital Rotation matrix for I state' - CALL WRTMAT (CISHL(IIOFF), NI, NI, NI, NI) - WRITE (6, *) ' Orbital Rotation matrix for F state' - CALL WRTMAT (CFSHL(IFOFF), NF, NF, NF, NF) - WRITE (6, *) - ENDIF + ' new overlap matrix ( should be 1 on diag, 0 elsewhere )' + CALL WRTMAT (SCR(KLSIF), NI, NF, NI, NF) + ENDIF + + IF (NTEST >= 1) THEN + WRITE (6, *) + WRITE (6, *) ' Orbital Rotation matrix for I state' + CALL WRTMAT (CISHL(IIOFF), NI, NI, NI, NI) + WRITE (6, *) ' Orbital Rotation matrix for F state' + CALL WRTMAT (CFSHL(IFOFF), NF, NF, NF, NF) + WRITE (6, *) + ENDIF ! !. Matrix for counterrotation of CI coefficients, initial state ! - KLTI = KLSIF - CALL PAMTMT (SCR(KLCI), SCR(KLTI), SCR(KLSCR), NI) - DO I = 1, NI - TII = SCR(KLTI-1+(I-1)*NI+I) - TIII = 1.0D0/TII - CALL SCALVE (SCR(KLTI+(I-1)*NI), TIII, I - 1) - END DO - CALL COPVEC (SCR(KLTI), CICI(IIOFF), NI*NI) + KLTI = KLSIF + CALL PAMTMT (SCR(KLCI), SCR(KLTI), SCR(KLSCR), NI) + DO I = 1, NI + TII = SCR(KLTI-1+(I-1)*NI+I) + TIII = 1.0D0/TII + CALL SCALVE (SCR(KLTI+(I-1)*NI), TIII, I - 1) + END DO + CALL COPVEC (SCR(KLTI), CICI(IIOFF), NI*NI) ! !. Matrix for counterrotation of CI coefficients, Final state ! - KLTF = KLSIF - CALL PAMTMT (SCR(KLCF), SCR(KLTF), SCR(KLSCR), NF) - DO I = 1, NF - TII = SCR(KLTF-1+(I-1)*NF+I) - TIII = 1.0D0/TII - CALL SCALVE (SCR(KLTF+(I-1)*NF), TIII, I - 1) - END DO - CALL COPVEC (SCR(KLTF), CFCI(IFOFF), NF*NF) - IF (NTEST < 1) CYCLE - WRITE (6, *) - WRITE (6, *) ' CI-Rotation matrix for I state' - CALL WRTMAT (CICI(IIOFF), NI, NI, NI, NI) - WRITE (6, *) ' CI-Rotation matrix for F state' - CALL WRTMAT (CFCI(IFOFF), NF, NF, NF, NF) - WRITE (6, *) - - END DO -! - RETURN - END SUBROUTINE BIOTR1 + KLTF = KLSIF + CALL PAMTMT (SCR(KLCF), SCR(KLTF), SCR(KLSCR), NF) + DO I = 1, NF + TII = SCR(KLTF-1+(I-1)*NF+I) + TIII = 1.0D0/TII + CALL SCALVE (SCR(KLTF+(I-1)*NF), TIII, I - 1) + END DO + CALL COPVEC (SCR(KLTF), CFCI(IFOFF), NF*NF) + IF (NTEST < 1) CYCLE + WRITE (6, *) + WRITE (6, *) ' CI-Rotation matrix for I state' + CALL WRTMAT (CICI(IIOFF), NI, NI, NI, NI) + WRITE (6, *) ' CI-Rotation matrix for F state' + CALL WRTMAT (CFCI(IFOFF), NF, NF, NF, NF) + WRITE (6, *) + + END DO +! + RETURN + END SUBROUTINE BIOTR1 diff --git a/src/appl/rbiotransform90_mpi/biotr1_I.f90 b/src/appl/rbiotransform90_mpi/biotr1_I.f90 index 60a7f78ef..3743a06a2 100644 --- a/src/appl/rbiotransform90_mpi/biotr1_I.f90 +++ b/src/appl/rbiotransform90_mpi/biotr1_I.f90 @@ -1,28 +1,28 @@ - MODULE biotr1_I + MODULE biotr1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE biotr1 (PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, NGRID, MXL& - , SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NGRID,*) :: PI - REAL(DOUBLE), DIMENSION(NGRID,*) :: QI - INTEGER, DIMENSION(MXL), INTENT(IN) :: NLI - INTEGER, DIMENSION(MXL) :: NINSHLI - REAL(DOUBLE), DIMENSION(NGRID,*) :: PF - REAL(DOUBLE), DIMENSION(NGRID,*) :: QF - INTEGER, DIMENSION(MXL), INTENT(IN) :: NLF - INTEGER, DIMENSION(MXL) :: NINSHLF - INTEGER, INTENT(IN) :: NGRID - INTEGER, INTENT(IN) :: MXL - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR - INTEGER, INTENT(IN) :: LSCR - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), DIMENSION(*) :: CISHL - REAL(DOUBLE), DIMENSION(*) :: CICI - REAL(DOUBLE), DIMENSION(*) :: CFSHL - REAL(DOUBLE), DIMENSION(*) :: CFCI - END SUBROUTINE - END INTERFACE - END MODULE + , SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NGRID,*) :: PI + REAL(DOUBLE), DIMENSION(NGRID,*) :: QI + INTEGER, DIMENSION(MXL), INTENT(IN) :: NLI + INTEGER, DIMENSION(MXL) :: NINSHLI + REAL(DOUBLE), DIMENSION(NGRID,*) :: PF + REAL(DOUBLE), DIMENSION(NGRID,*) :: QF + INTEGER, DIMENSION(MXL), INTENT(IN) :: NLF + INTEGER, DIMENSION(MXL) :: NINSHLF + INTEGER, INTENT(IN) :: NGRID + INTEGER, INTENT(IN) :: MXL + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR + INTEGER, INTENT(IN) :: LSCR + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), DIMENSION(*) :: CISHL + REAL(DOUBLE), DIMENSION(*) :: CICI + REAL(DOUBLE), DIMENSION(*) :: CFSHL + REAL(DOUBLE), DIMENSION(*) :: CFCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/biotrmpi.f90 b/src/appl/rbiotransform90_mpi/biotrmpi.f90 index 0b75f44c3..d23a6c061 100644 --- a/src/appl/rbiotransform90_mpi/biotrmpi.f90 +++ b/src/appl/rbiotransform90_mpi/biotrmpi.f90 @@ -11,7 +11,7 @@ ! J. Olsen, M.R. Godefroid, P. Jonsson, P.A. Malmqvist and * ! C. Froese Fischer, Phys. Rev. E, 4499 (1995) * ! * - PROGRAM BIOTR + PROGRAM BIOTR ! * ! Program written by * ! * @@ -24,13 +24,13 @@ PROGRAM BIOTR ! and for reducing usage of CPU memory. NIST, October 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:17:22 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:17:22 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE default_C, ONLY: ndef, ndump USE sbdat_C, ONLY: NLMAX, KAMAX, NSHLII, NSHLFF @@ -41,41 +41,41 @@ PROGRAM BIOTR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setmc_I - USE setcon_I - USE setiso_I - USE radpar_I - USE radgrd_I - USE setqic_I - USE fname_I - USE setcslb_I - USE tcsl_I - USE kapdata_I - USE lodrwfi_I - USE lodrwff_I - USE brkt_I - USE gets_I - USE biotr1_I - USE radfile_I + USE getyn_I + USE setmc_I + USE setcon_I + USE setiso_I + USE radpar_I + USE radgrd_I + USE setqic_I + USE fname_I + USE setcslb_I + USE tcsl_I + USE kapdata_I + USE lodrwfi_I + USE lodrwff_I + USE brkt_I + USE gets_I + USE biotr1_I + USE radfile_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- -!GG INTEGER, PARAMETER :: LWORK1 = 100000 +!GG INTEGER, PARAMETER :: LWORK1 = 100000 INTEGER, PARAMETER :: LWORK1 = 10000000 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NLMAX) :: NINSHLI, NINSHLF - INTEGER :: NTESTG, NTESTL, NTEST, INPCI, NCORE1, NCORE2, MXL, K + INTEGER, DIMENSION(NLMAX) :: NINSHLI, NINSHLF + INTEGER :: NTESTG, NTESTL, NTEST, INPCI, NCORE1, NCORE2, MXL, K INTEGER :: NCOUNT1,lenperm,lentmp,iii,ncore_not_used - REAL(DOUBLE), DIMENSION(LWORK1) :: WORK - REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CISHL - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: S - REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CFSHL - LOGICAL :: YES - CHARACTER, DIMENSION(2) :: NAME*24 + REAL(DOUBLE), DIMENSION(LWORK1) :: WORK + REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CISHL + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: S + REAL(DOUBLE), DIMENSION(NLMAX*NLMAX) :: CFSHL + LOGICAL :: YES + CHARACTER, DIMENSION(2) :: NAME*24 CHARACTER(LEN=3) :: idstring CHARACTER(LEN=128) :: ISOFILE CHARACTER(LEN=128), DIMENSION(2) :: FULLNAME(2) @@ -94,43 +94,43 @@ PROGRAM BIOTR lenperm = LEN_TRIM (permdir) lentmp = LEN_TRIM (tmpdir) -!======================================================================= +!======================================================================= ! Debug flags ! - NTESTG = 0 - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) + NTESTG = 0 + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) ! if (myid .eq. 0) then PRINT * PRINT * - WRITE (6, *) 'Default settings?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDEF = 0 - NDUMP = 1 - ELSE - NDEF = 1 - WRITE (6, *) 'Dump angular data on file?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDUMP = 1 - ELSE - NDUMP = 0 - ENDIF - ENDIF - WRITE (6, *) 'Input from a CI calculation?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - INPCI = 0 - ELSE - INPCI = 1 - ENDIF + WRITE (6, *) 'Default settings?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDEF = 0 + NDUMP = 1 + ELSE + NDEF = 1 + WRITE (6, *) 'Dump angular data on file?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDUMP = 1 + ELSE + NDUMP = 0 + ENDIF + ENDIF + WRITE (6, *) 'Input from a CI calculation?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + INPCI = 0 + ELSE + INPCI = 1 + ENDIF endif !myid=0 CALL MPI_Bcast (NDEF,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (NDUMP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -138,33 +138,33 @@ PROGRAM BIOTR ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Open, check, load data from, and close the .iso file ! - CALL SETISO (ISOFILE) + CALL SETISO (ISOFILE) ! ! Determine the parameters controlling the radial grid ! - CALL RADPAR + CALL RADPAR ! ! Generate the radial grid ! - CALL RADGRD + CALL RADGRD ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Obtain the names of the initial and final state files ! and open files where the transformed orbitals and CI ! coefficients are to be dumped ! - if (myid .eq. 0) CALL FNAME (NAME) + if (myid .eq. 0) CALL FNAME (NAME) CALL MPI_Bcast (NAME,48,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr) print *, 'DBG: myid=',myid, ' name(1)=', name(1) print *, 'DBG: myid=',myid, ' name(2)=', name(2) @@ -176,69 +176,69 @@ PROGRAM BIOTR ! ! Open, check, load data from and close the initial state CSL file. ! - CALL SETCSLB (FULLNAME(1), NCORE1,1) + CALL SETCSLB (FULLNAME(1), NCORE1,1) ! ! Transfer the data to the initial state COMMON ! - CALL TCSL (1) + CALL TCSL (1) ! ! Open, check, load data from and close the final state CSL file. ! - CALL SETCSLB (FULLNAME(2), NCORE2,2) + CALL SETCSLB (FULLNAME(2), NCORE2,2) ! ! Transfer the data to the final state COMMON ! - CALL TCSL (2) + CALL TCSL (2) ! ! Determine the number of kappa quantum numbers and ! the number of orbitals for each kappa quantum number ! for the initial state and final states ! - CALL KAPDATA (NTESTG, NCORE1, NCORE2) + CALL KAPDATA (NTESTG, NCORE1, NCORE2) ! ! Read the the radial orbitals for the initial state ! - CALL LODRWFI (FULLNAME(1), NTESTG) + CALL LODRWFI (FULLNAME(1), NTESTG) ! ! Read the the radial orbitals for the initial state ! - CALL LODRWFF (FULLNAME(2), NTESTG) + CALL LODRWFF (FULLNAME(2), NTESTG) ! ! Calculate the radial overlap matrices ! if (myid .eq. 0) then - WRITE (*, *) - WRITE (*, *) ' ******************************************' - WRITE (*, *) ' Overlap matrix before orbital rotations' - WRITE (*, *) ' *****************************************' - WRITE (*, *) + WRITE (*, *) + WRITE (*, *) ' ******************************************' + WRITE (*, *) ' Overlap matrix before orbital rotations' + WRITE (*, *) ' *****************************************' + WRITE (*, *) endif!myid=0 - - CALL BRKT - - CALL GETS (S, NWII, NWFF) - + + CALL BRKT + + CALL GETS (S, NWII, NWFF) + ! ! Once we have the overlap matrices ! we can manipulate the initial and final state separately. ! - MXL = KAMAX + MXL = KAMAX ! !. Calculate biorthonormal orbitals, and orbital matrix !. for counter transformation of CI coefficients. ! CALL BIOTR1 (PFII, QFII, NSHLII, NINSHLI, PFFF, QFFF, & NSHLFF, NINSHLF, NNNP, KAMAX, WORK, LWORK1, NTESTG, & - CISHL, CICI, CFSHL, CFCI) + CISHL, CICI, CFSHL, CFCI) if (myid .eq. 0) then - WRITE (*, *) - WRITE (*, *) ' ****************************************' - WRITE (*, *) ' Overlap matrix after orbital rotations' - WRITE (*, *) ' ****************************************' - WRITE (*, *) + WRITE (*, *) + WRITE (*, *) ' ****************************************' + WRITE (*, *) ' Overlap matrix after orbital rotations' + WRITE (*, *) ' ****************************************' + WRITE (*, *) endif !myid=0 - - CALL BRKT + + CALL BRKT ! ! Write the transformed radial functions to file ! @@ -248,7 +248,7 @@ PROGRAM BIOTR ! The coefficients are dumped on files one kappa in turn and ! thus the different kappa can be manipulated independently. ! The interface with the transformation part is in the routine mcp -! +! iii = len_trim(startdir) call sys_chdir(trim(startdir),iii,ierr) !GG CALL SETCSLA(NAME(1), ncore_not_used) @@ -269,7 +269,7 @@ PROGRAM BIOTR ! The coefficients are dumped on files one kappa in turn and ! thus the different kappa can be manipulated independently. ! The interface with the transformation part is in the routine mcp -! +! iii = len_trim(startdir) call sys_chdir(trim(startdir),iii,ierr) !GG CALL SETCSLA(NAME(2), ncore_not_used) @@ -289,6 +289,6 @@ PROGRAM BIOTR CALL stopmpi2 (myid, nprocs, host, lenhost, & ncount1, 'RBIOTRANSFORM_MPI') -!======================================================================= - STOP - END PROGRAM BIOTR +!======================================================================= + STOP + END PROGRAM BIOTR diff --git a/src/appl/rbiotransform90_mpi/bndinv.f90 b/src/appl/rbiotransform90_mpi/bndinv.f90 index 4f55ce512..1b2b0a29c 100644 --- a/src/appl/rbiotransform90_mpi/bndinv.f90 +++ b/src/appl/rbiotransform90_mpi/bndinv.f90 @@ -3,7 +3,7 @@ ! B N D I N V ! ------------------------------------------------------------------ ! - SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) + SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) ! ! DOUBLE PRECISION MATRIX INVERSION SUBROUTINE ! FROM "DLYTAP". @@ -11,151 +11,151 @@ SUBROUTINE BNDINV(A, EL, N, DETERM, EPSIL, ITEST, NSIZE) !* DOUBLE PRECISION E,F !* DOUBLE PRECISION A,EL,D,DSQRT,C,S,DETERP !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(OUT) :: ITEST - INTEGER , INTENT(IN) :: NSIZE - REAL(DOUBLE) , INTENT(OUT) :: DETERM - REAL(DOUBLE) , INTENT(IN) :: EPSIL - REAL(DOUBLE) , INTENT(INOUT) :: A(NSIZE,NSIZE) - REAL(DOUBLE) , INTENT(INOUT) :: EL(NSIZE,NSIZE) + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(OUT) :: ITEST + INTEGER , INTENT(IN) :: NSIZE + REAL(DOUBLE) , INTENT(OUT) :: DETERM + REAL(DOUBLE) , INTENT(IN) :: EPSIL + REAL(DOUBLE) , INTENT(INOUT) :: A(NSIZE,NSIZE) + REAL(DOUBLE) , INTENT(INOUT) :: EL(NSIZE,NSIZE) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISL2, K000FX, INDSNL, I, J, N1, M, K, J1, I1, KS - REAL(DOUBLE) :: D, C, S, DETERP, F, E, EPSILP, RAT + INTEGER :: ISL2, K000FX, INDSNL, I, J, N1, M, K, J1, I1, KS + REAL(DOUBLE) :: D, C, S, DETERP, F, E, EPSILP, RAT !----------------------------------------------- - IF (N < 2) GO TO 140 - ISL2 = 0 - K000FX = 2 - IF (ISL2 == 0) INDSNL = 2 - IF (ISL2 == 1) INDSNL = 1 + IF (N < 2) GO TO 140 + ISL2 = 0 + K000FX = 2 + IF (ISL2 == 0) INDSNL = 2 + IF (ISL2 == 1) INDSNL = 1 ! CALL SLITET(2,INDSNL) ! CALL OVERFL(K000FX) ! CALL DVCHK(K000FX) ! ! SET EL = IDENTITY MATRIX - DO I = 1, N - EL(I,:N) = 0.0D0 - EL(I,I) = 1.0D0 - END DO + DO I = 1, N + EL(I,:N) = 0.0D0 + EL(I,I) = 1.0D0 + END DO ! ! TRIANGULARIZE A, FORM EL ! - N1 = N - 1 - M = 2 - DO J = 1, N1 - DO I = M, N - IF (A(I,J) == 0.0D0) CYCLE - D = DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J)) - C = A(J,J)/D - S = A(I,J)/D - DO K = J, N - D = C*A(J,K) + S*A(I,K) - A(I,K) = C*A(I,K) - S*A(J,K) - A(J,K) = D - END DO - DO K = 1, N - D = C*EL(J,K) + S*EL(I,K) - EL(I,K) = C*EL(I,K) - S*EL(J,K) - EL(J,K) = D - END DO - END DO - M = M + 1 - END DO + N1 = N - 1 + M = 2 + DO J = 1, N1 + DO I = M, N + IF (A(I,J) == 0.0D0) CYCLE + D = DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J)) + C = A(J,J)/D + S = A(I,J)/D + DO K = J, N + D = C*A(J,K) + S*A(I,K) + A(I,K) = C*A(I,K) - S*A(J,K) + A(J,K) = D + END DO + DO K = 1, N + D = C*EL(J,K) + S*EL(I,K) + EL(I,K) = C*EL(I,K) - S*EL(J,K) + EL(J,K) = D + END DO + END DO + M = M + 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,51),K000FX ! ! CALCULATE THE DETERMINANT - DETERP = A(1,1) - DO I = 2, N - DETERP = DETERP*A(I,I) - END DO - DETERM = DETERP + DETERP = A(1,1) + DO I = 2, N + DETERP = DETERP*A(I,I) + END DO + DETERM = DETERP ! CALL OVERFL(K000FX) ! GO TO (140,520,520),K000FX ! ! IS MATRIX SINGULAR - F = A(1,1) - E = A(1,1) - DO I = 2, N - IF (DABS(F) < DABS(A(I,I))) F = A(I,I) - IF (DABS(E) <= DABS(A(I,I))) CYCLE - E = A(I,I) - END DO - EPSILP = EPSIL - IF (EPSILP <= 0) EPSILP = 1.0E-8 - RAT = E/F - IF (ABS(RAT) < EPSILP) GO TO 130 + F = A(1,1) + E = A(1,1) + DO I = 2, N + IF (DABS(F) < DABS(A(I,I))) F = A(I,I) + IF (DABS(E) <= DABS(A(I,I))) CYCLE + E = A(I,I) + END DO + EPSILP = EPSIL + IF (EPSILP <= 0) EPSILP = 1.0E-8 + RAT = E/F + IF (ABS(RAT) < EPSILP) GO TO 130 ! ! INVERT TRIANGULAR MATRIX - J = N - DO J1 = 1, N + J = N + DO J1 = 1, N ! CALL SLITE(2) - I = J - ISL2 = 1 - DO I1 = 1, J + I = J + ISL2 = 1 + DO I1 = 1, J ! CALL SLITET(2,K000FX) - IF (ISL2 == 0) K000FX = 2 - IF (ISL2 == 1) THEN - K000FX = 1 - ISL2 = 0 - ENDIF - SELECT CASE (K000FX) - CASE DEFAULT - A(I,J) = 1.0D0/A(I,I) - CASE (2) - KS = I + 1 - D = 0.0D0 - D = SUM(A(I,KS:J)*A(KS:J,J)) - A(I,J) = -D/A(I,I) - END SELECT - 1003 CONTINUE - I = I - 1 - END DO - J = J - 1 - END DO + IF (ISL2 == 0) K000FX = 2 + IF (ISL2 == 1) THEN + K000FX = 1 + ISL2 = 0 + ENDIF + SELECT CASE (K000FX) + CASE DEFAULT + A(I,J) = 1.0D0/A(I,I) + CASE (2) + KS = I + 1 + D = 0.0D0 + D = SUM(A(I,KS:J)*A(KS:J,J)) + A(I,J) = -D/A(I,I) + END SELECT + 1003 CONTINUE + I = I - 1 + END DO + J = J - 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,103,103),K000FX - + !103 CALL DVCHK(K000FX) ! GO TO (140,105),K000FX ! ! PREMULTIPLY EL BY INVERTED TRIANGULAR MATRIX - M = 1 - DO I = 1, N - DO J = 1, N - D = 0.0D0 - D = SUM(A(I,M:N)*EL(M:N,J)) - EL(I,J) = D - END DO - M = M + 1 - END DO + M = 1 + DO I = 1, N + DO J = 1, N + D = 0.0D0 + D = SUM(A(I,M:N)*EL(M:N,J)) + EL(I,J) = D + END DO + M = M + 1 + END DO ! CALL OVERFL(K000FX) ! GO TO (140,123,123),K000FX ! ! RECOPY EL TO A - A(:N,:N) = EL(:N,:N) - ITEST = 0 + A(:N,:N) = EL(:N,:N) + ITEST = 0 !126 IF(INDSNL.EQ.1)CALL SLITE(2) - 126 CONTINUE - IF (INDSNL == 1) ISL2 = 1 - RETURN + 126 CONTINUE + IF (INDSNL == 1) ISL2 = 1 + RETURN ! - 130 CONTINUE - ITEST = 1 - GO TO 126 - 140 CONTINUE - ITEST = -1 - GO TO 126 - END SUBROUTINE BNDINV + 130 CONTINUE + ITEST = 1 + GO TO 126 + 140 CONTINUE + ITEST = -1 + GO TO 126 + END SUBROUTINE BNDINV diff --git a/src/appl/rbiotransform90_mpi/bndinv_I.f90 b/src/appl/rbiotransform90_mpi/bndinv_I.f90 index e1f850286..faeba5aa4 100644 --- a/src/appl/rbiotransform90_mpi/bndinv_I.f90 +++ b/src/appl/rbiotransform90_mpi/bndinv_I.f90 @@ -1,17 +1,17 @@ - MODULE bndinv_I + MODULE bndinv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bndinv (A, EL, N, DETERM, EPSIL, ITEST, NSIZE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: A - REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: EL - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(OUT) :: DETERM - REAL(DOUBLE), INTENT(IN) :: EPSIL - INTEGER, INTENT(OUT) :: ITEST - INTEGER, INTENT(IN) :: NSIZE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bndinv (A, EL, N, DETERM, EPSIL, ITEST, NSIZE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: A + REAL(DOUBLE), DIMENSION(NSIZE,1), INTENT(INOUT) :: EL + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(OUT) :: DETERM + REAL(DOUBLE), INTENT(IN) :: EPSIL + INTEGER, INTENT(OUT) :: ITEST + INTEGER, INTENT(IN) :: NSIZE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/brkt.f90 b/src/appl/rbiotransform90_mpi/brkt.f90 index cb6917a2d..0045416a2 100644 --- a/src/appl/rbiotransform90_mpi/brkt.f90 +++ b/src/appl/rbiotransform90_mpi/brkt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BRKT + SUBROUTINE BRKT ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE BRKT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE biorb_C @@ -23,46 +23,46 @@ SUBROUTINE BRKT !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! - - DO I = 1, NWII - DO J = 1, NWFF - IF (NAKII(I) /= NAKFF(J)) CYCLE + + DO I = 1, NWII + DO J = 1, NWFF + IF (NAKII(I) /= NAKFF(J)) CYCLE ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA = 0.0D0 + TA = 0.0D0 ! TA(1)=0.D0 - DO L = 2, MTP + DO L = 2, MTP TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - - BRAKET(I,J) = RESULT - if (myid .eq. 0) & + CALL QUAD (RESULT) + + BRAKET(I,J) = RESULT + if (myid .eq. 0) & WRITE (*,9) '<',NPII(I),NHII(I),'|',NPFF(J),NHFF(J),'> =',& - BRAKET(I,J) - END DO - END DO + BRAKET(I,J) + END DO + END DO ! - 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) - - RETURN - END SUBROUTINE BRKT + 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) + + RETURN + END SUBROUTINE BRKT diff --git a/src/appl/rbiotransform90_mpi/brkt_I.f90 b/src/appl/rbiotransform90_mpi/brkt_I.f90 index 7bdeadb75..a01fd0870 100644 --- a/src/appl/rbiotransform90_mpi/brkt_I.f90 +++ b/src/appl/rbiotransform90_mpi/brkt_I.f90 @@ -1,9 +1,9 @@ - MODULE brkt_I + MODULE brkt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE brkt - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE brkt + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/citragmpi.f90 b/src/appl/rbiotransform90_mpi/citragmpi.f90 index e44877858..128186c5c 100644 --- a/src/appl/rbiotransform90_mpi/citragmpi.f90 +++ b/src/appl/rbiotransform90_mpi/citragmpi.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * ! * - SUBROUTINE CITRAG(CIIN,NCSF,NCIV,L,NSHL,T,NIN,NTESTG,CIOUT,SCR) + SUBROUTINE CITRAG(CIIN,NCSF,NCIV,L,NSHL,T,NIN,NTESTG,CIOUT,SCR) ! * ! Calculate the action of the operator * ! * @@ -33,13 +33,13 @@ SUBROUTINE CITRAG(CIIN,NCSF,NCIV,L,NSHL,T,NIN,NTESTG,CIOUT,SCR) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE sbdat1_C USE orb_C USE mpi_C @@ -47,109 +47,109 @@ SUBROUTINE CITRAG(CIIN,NCSF,NCIV,L,NSHL,T,NIN,NTESTG,CIOUT,SCR) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE wrtmat_I - USE scalve_I -! USE copvec_I - USE tiinig_I - USE ti1tv_I - USE vecsum_I + USE wrtmat_I + USE scalve_I +! USE copvec_I + USE tiinig_I + USE ti1tv_I + USE vecsum_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCSF - INTEGER :: NCIV - INTEGER :: L - INTEGER :: NSHL - INTEGER, INTENT(IN) :: NIN - INTEGER :: NTESTG - REAL(DOUBLE) :: CIIN(NCSF,NCIV) - REAL(DOUBLE) :: T(NSHL,NSHL) - REAL(DOUBLE) :: CIOUT(NCSF,NCIV) - REAL(DOUBLE) :: SCR(NCSF,NCIV) + INTEGER :: NCSF + INTEGER :: NCIV + INTEGER :: L + INTEGER :: NSHL + INTEGER, INTENT(IN) :: NIN + INTEGER :: NTESTG + REAL(DOUBLE) :: CIIN(NCSF,NCIV) + REAL(DOUBLE) :: T(NSHL,NSHL) + REAL(DOUBLE) :: CIOUT(NCSF,NCIV) + REAL(DOUBLE) :: SCR(NCSF,NCIV) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTESTL, NTEST, IIN, IPOT, I, N - REAL(DOUBLE) :: FACTOR, TII, XNFACI - REAL(DOUBLE) :: SCRtmp(NCSF,NCIV) + INTEGER :: NTESTL, NTEST, IIN, IPOT, I, N + REAL(DOUBLE) :: FACTOR, TII, XNFACI + REAL(DOUBLE) :: SCRtmp(NCSF,NCIV) !----------------------------------------------- ! - - NTESTL = 0 - NTEST = MAX(NTESTG,NTESTL) - NTEST = 0 - -! - IF (NTEST >= 10) THEN - WRITE (6, *) - WRITE (6, *) ' ***************' - WRITE (6, *) ' Entering CITRAG' - WRITE (6, *) ' ***************' - WRITE (6, *) - ENDIF - IF (NTEST >= 100) THEN - WRITE (6, *) ' Input CI vectors ' - CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) ' Transformation matrix T' - CALL WRTMAT (T, NSHL, NSHL, NSHL, NSHL) - ENDIF + + NTESTL = 0 + NTEST = MAX(NTESTG,NTESTL) + NTEST = 0 + +! + IF (NTEST >= 10) THEN + WRITE (6, *) + WRITE (6, *) ' ***************' + WRITE (6, *) ' Entering CITRAG' + WRITE (6, *) ' ***************' + WRITE (6, *) + ENDIF + IF (NTEST >= 100) THEN + WRITE (6, *) ' Input CI vectors ' + CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) ' Transformation matrix T' + CALL WRTMAT (T, NSHL, NSHL, NSHL, NSHL) + ENDIF ! !. Factor from inactive shells ! - IF (NIN /= 0) THEN - FACTOR = 1.0D0 - DO IIN = 1, NIN - FACTOR = FACTOR*T(IIN,IIN) - END DO + IF (NIN /= 0) THEN + FACTOR = 1.0D0 + DO IIN = 1, NIN + FACTOR = FACTOR*T(IIN,IIN) + END DO ! ! IPOT = 2*(2*L+1) (number of m_lm_s. This should be replaced ! by (2j+1) corresponding to L) ! - IPOT = 2*IABS(NAK(NSHLP(L,IIN))) - FACTOR = FACTOR**IPOT - CALL SCALVE (CIIN, FACTOR, NCIV*NCSF) - ENDIF - IF (NIN == NSHL) CALL COPVEC (CIIN, CIOUT, NCIV*NCSF) + IPOT = 2*IABS(NAK(NSHLP(L,IIN))) + FACTOR = FACTOR**IPOT + CALL SCALVE (CIIN, FACTOR, NCIV*NCSF) + ENDIF + IF (NIN == NSHL) CALL COPVEC (CIIN, CIOUT, NCIV*NCSF) ! - DO I = NIN + 1, NSHL - IF (NTEST >= 100) WRITE (6, *) ' Loop I,L = ', I, L + DO I = NIN + 1, NSHL + IF (NTEST >= 100) WRITE (6, *) ' Loop I,L = ', I, L ! !. The diagonal contribution ! - TII = T(I,I) - CALL TIINIG (CIIN, NCSF, NCIV, I, L, TII, CIOUT, NTESTG) + TII = T(I,I) + CALL TIINIG (CIIN, NCSF, NCIV, I, L, TII, CIOUT, NTESTG) ! IF (LWORK2.LT.NCIV*NCSF) THEN ! WRITE(*,*) 'In CITRAG: Dimension of LWORK2 must be', ! & 'increased to at least',NCIV*NCSF ! ENDIF - CALL COPVEC (CIOUT, SCR, NCIV*NCSF) + CALL COPVEC (CIOUT, SCR, NCIV*NCSF) ! !. Off diagonal contributions ! - XNFACI = 1.0D0 - DO N = 1, 2*IABS(NAK(NSHLP(L,I))) - IF (NTEST >= 100) WRITE (6, *) ' Loop N = ', N + XNFACI = 1.0D0 + DO N = 1, 2*IABS(NAK(NSHLP(L,I))) + IF (NTEST >= 100) WRITE (6, *) ' Loop N = ', N ! ! T ** (N-1) is supposed to be in SCR, copy to CIIN ! and apply S ! - CALL COPVEC (SCR, CIIN, NCIV*NCSF) - CALL TI1TV (CIIN,NCSF,NCIV,I,L,T(1,I),NSHL,SCRtmp,NTESTG) + CALL COPVEC (SCR, CIIN, NCIV*NCSF) + CALL TI1TV (CIIN,NCSF,NCIV,I,L,T(1,I),NSHL,SCRtmp,NTESTG) ! CALL MPI_ALLREDUCE(SCRtmp(1,1),SCR(1,1),NCIV*NCSF, & CALL MPI_ALLREDUCE(SCRtmp,SCR,NCIV*NCSF, & MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr) - XNFACI = XNFACI/FLOAT(N) - CALL VECSUM (CIOUT, CIOUT, SCR, 1.0D0, XNFACI, NCIV*NCSF) - END DO - CALL COPVEC (CIOUT, CIIN, NCIV*NCSF) + XNFACI = XNFACI/FLOAT(N) + CALL VECSUM (CIOUT, CIOUT, SCR, 1.0D0, XNFACI, NCIV*NCSF) + END DO + CALL COPVEC (CIOUT, CIIN, NCIV*NCSF) ! - END DO + END DO ! - IF (NTEST >= 100) THEN - WRITE (6, *) ' Output CI vectors L = ', L - CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) - ENDIF + IF (NTEST >= 100) THEN + WRITE (6, *) ' Output CI vectors L = ', L + CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) + ENDIF ! - RETURN + RETURN END SUBROUTINE CITRAG diff --git a/src/appl/rbiotransform90_mpi/citragmpi_I.f90 b/src/appl/rbiotransform90_mpi/citragmpi_I.f90 index 26695ca16..e51840ebb 100644 --- a/src/appl/rbiotransform90_mpi/citragmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/citragmpi_I.f90 @@ -1,20 +1,20 @@ - MODULE citrag_I + MODULE citrag_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE citrag (CIIN,NCSF,NCIV,L,NSHL,T,NIN,NTESTG,CIOUT,SCR) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIIN - INTEGER, INTENT(IN) :: NCSF - INTEGER, INTENT(IN) :: NCIV - INTEGER, INTENT(IN) :: L - INTEGER, INTENT(IN) :: NSHL - REAL(DOUBLE), DIMENSION(NSHL,NSHL), INTENT(IN) :: T - INTEGER, INTENT(IN) :: NIN - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIOUT - REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: SCR - END SUBROUTINE - END INTERFACE - END MODULE + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIIN + INTEGER, INTENT(IN) :: NCSF + INTEGER, INTENT(IN) :: NCIV + INTEGER, INTENT(IN) :: L + INTEGER, INTENT(IN) :: NSHL + REAL(DOUBLE), DIMENSION(NSHL,NSHL), INTENT(IN) :: T + INTEGER, INTENT(IN) :: NIN + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIOUT + REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: SCR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/copvec.f90 b/src/appl/rbiotransform90_mpi/copvec.f90 index 274d43977..c621585d3 100644 --- a/src/appl/rbiotransform90_mpi/copvec.f90 +++ b/src/appl/rbiotransform90_mpi/copvec.f90 @@ -3,20 +3,20 @@ ! C O P V E C ! ------------------------------------------------------------------ ! - SUBROUTINE COPVEC(FROM, TO, NDIM) + SUBROUTINE COPVEC(FROM, TO, NDIM) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM + INTEGER, INTENT(IN) :: NDIM REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO ! - TO(:NDIM) = FROM(:NDIM) + TO(:NDIM) = FROM(:NDIM) ! - RETURN - END SUBROUTINE COPVEC + RETURN + END SUBROUTINE COPVEC diff --git a/src/appl/rbiotransform90_mpi/copvec_I.f90 b/src/appl/rbiotransform90_mpi/copvec_I.f90 index 63beed024..a8b27fabc 100644 --- a/src/appl/rbiotransform90_mpi/copvec_I.f90 +++ b/src/appl/rbiotransform90_mpi/copvec_I.f90 @@ -1,11 +1,11 @@ - MODULE copvec_I + MODULE copvec_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 - SUBROUTINE copvec (FROM, TO, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM - REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 + SUBROUTINE copvec (FROM, TO, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: FROM + REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: TO + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/fname.f90 b/src/appl/rbiotransform90_mpi/fname.f90 index 86d848951..de9e4233f 100644 --- a/src/appl/rbiotransform90_mpi/fname.f90 +++ b/src/appl/rbiotransform90_mpi/fname.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE FNAME(NAME) + SUBROUTINE FNAME(NAME) ! * ! Determines the name of the initial and final states * ! In addition this subroutine determines which J symmetries * @@ -9,8 +9,8 @@ SUBROUTINE FNAME(NAME) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:19:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:19:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! C O M M O N B l o c k s @@ -19,40 +19,40 @@ SUBROUTINE FNAME(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I - LOGICAL :: YES + INTEGER :: J, I + LOGICAL :: YES !----------------------------------------------- ! ! ! Obtain the names of the initial and final state files ! - 1 CONTINUE - WRITE (6, *) ' Name of the Initial state' - READ (*, '(A)') NAME(1) - - WRITE (6, *) ' Name of the Final state' - READ (*, '(A)') NAME(2) + 1 CONTINUE + WRITE (6, *) ' Name of the Initial state' + READ (*, '(A)') NAME(1) + + WRITE (6, *) ' Name of the Final state' + READ (*, '(A)') NAME(2) ! - J = INDEX(NAME(1),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(1),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! - J = INDEX(NAME(2),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(2),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! Per april 2007 ! Check if the initial and final states are identical. @@ -71,23 +71,23 @@ SUBROUTINE FNAME(NAME) END IF ! end Per 2007 - WRITE (6, *) ' Transformation of all J symmetries?' - YES = GETYN() - IF (YES) THEN - NTRANS = 0 - ELSE - NTRANS = 1 - WRITE (6, *) ' Number of initial state J symmetries to be transformed' - READ (*, *) JQJ1 - WRITE (6, *) ' Give the J symmetries in the form 2*J' - READ (*, *) (ITJQJ1(I),I=1,JQJ1) - ITJQJ1(:JQJ1) = ITJQJ1(:JQJ1) + 1 - WRITE (6, *) ' Number of final state J symmetries to be transformed' - READ (*, *) JQJ2 - WRITE (6, *) ' Give the J symmetries in the form 2*J' - READ (*, *) (ITJQJ2(I),I=1,JQJ2) - ITJQJ2(:JQJ2) = ITJQJ2(:JQJ2) + 1 - ENDIF - - RETURN - END SUBROUTINE FNAME + WRITE (6, *) ' Transformation of all J symmetries?' + YES = GETYN() + IF (YES) THEN + NTRANS = 0 + ELSE + NTRANS = 1 + WRITE (6, *) ' Number of initial state J symmetries to be transformed' + READ (*, *) JQJ1 + WRITE (6, *) ' Give the J symmetries in the form 2*J' + READ (*, *) (ITJQJ1(I),I=1,JQJ1) + ITJQJ1(:JQJ1) = ITJQJ1(:JQJ1) + 1 + WRITE (6, *) ' Number of final state J symmetries to be transformed' + READ (*, *) JQJ2 + WRITE (6, *) ' Give the J symmetries in the form 2*J' + READ (*, *) (ITJQJ2(I),I=1,JQJ2) + ITJQJ2(:JQJ2) = ITJQJ2(:JQJ2) + 1 + ENDIF + + RETURN + END SUBROUTINE FNAME diff --git a/src/appl/rbiotransform90_mpi/fname_I.f90 b/src/appl/rbiotransform90_mpi/fname_I.f90 index 25e5f6eb0..9b49cbb7a 100644 --- a/src/appl/rbiotransform90_mpi/fname_I.f90 +++ b/src/appl/rbiotransform90_mpi/fname_I.f90 @@ -1,10 +1,10 @@ - MODULE fname_I + MODULE fname_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fname (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE fname (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/getmixmpi.f90 b/src/appl/rbiotransform90_mpi/getmixmpi.f90 index 1a97fffd6..6ea0a55de 100644 --- a/src/appl/rbiotransform90_mpi/getmixmpi.f90 +++ b/src/appl/rbiotransform90_mpi/getmixmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETMIX(NAME, INPCI, IBLK) + SUBROUTINE GETMIX(NAME, INPCI, IBLK) ! * ! Open, check, load data from and close the rscf.mix file. * ! * @@ -9,20 +9,20 @@ SUBROUTINE GETMIX(NAME, INPCI, IBLK) ! Written by Farid A. Parpia Last revision: 25 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE def_C USE orb_C, ONLY: ncf, nw, iqa - USE EIGV_C - USE PRNT_C - USE SYMA_C - USE BLK_C + USE EIGV_C + USE PRNT_C + USE SYMA_C + USE BLK_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -30,70 +30,70 @@ SUBROUTINE GETMIX(NAME, INPCI, IBLK) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INPCI - INTEGER, INTENT(IN) :: IBLK + INTEGER, INTENT(IN) :: INPCI + INTEGER, INTENT(IN) :: IBLK CHARACTER, INTENT(IN) :: NAME*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IK, J, IOS, NB, IATJP, IASPA, I - CHARACTER :: G92MIX*6 + INTEGER :: IK, J, IOS, NB, IATJP, IASPA, I + CHARACTER :: G92MIX*6 !----------------------------------------------- - - IK = 30 - IF (IBLK == 1) THEN - J = INDEX(NAME,' ') - IF (INPCI == 0) THEN + + IK = 30 + IF (IBLK == 1) THEN + J = INDEX(NAME,' ') + IF (INPCI == 0) THEN OPEN(UNIT=IK, FILE=NAME(1:J-1)//'.cm', FORM='UNFORMATTED', STATUS=& - 'OLD') - ELSE + 'OLD') + ELSE OPEN(UNIT=IK, FILE=NAME(1:J-1)//'.m', FORM='UNFORMATTED', STATUS=& - 'OLD') - ENDIF - - READ (IK, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + 'OLD') + ENDIF + + READ (IK, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN WRITE (6, *) & - 'File', IK, 'Not a GRASP MIXing Coefficients File;' - CLOSE(IK) - STOP - ENDIF + 'File', IK, 'Not a GRASP MIXing Coefficients File;' + CLOSE(IK) + STOP + ENDIF ! READ (IK) NELECTOT, NCFTOT, NWTOT, NVECTOT, NVECSIZTOT, NBLOCK1 - IF (NELEC/=NELECTOT .OR. NW/=NWTOT) THEN + IF (NELEC/=NELECTOT .OR. NW/=NWTOT) THEN ! : (NCF .NE. NCFT) .OR. - WRITE (6, *) 'File', IK, 'is not an' - WRITE (6, *) ' appropriate to Coefficients file' - CLOSE(IK) - STOP - ENDIF - ENDIF + WRITE (6, *) 'File', IK, 'is not an' + WRITE (6, *) ' appropriate to Coefficients file' + CLOSE(IK) + STOP + ENDIF + ENDIF ! ! Load data from the rscf.mix file ! - WRITE (6, *) 'Loading MIXing Coefficients File ...' + WRITE (6, *) 'Loading MIXing Coefficients File ...' ! - READ (IK) NB, NCF, NVEC, IATJP, IASPA - CALL ALLOC (EVAL, NVEC, 'EVAL', 'GETMIX') - CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'GETMIX') - CALL ALLOC (IVEC, NVEC, 'IVEC', 'GETMIX') - CALL ALLOC (IATJPO, NVEC, 'IATJPO', 'GETMIX') - CALL ALLOC (IASPAR, NVEC, 'IASPAR', 'GETMIX') + READ (IK) NB, NCF, NVEC, IATJP, IASPA + CALL ALLOC (EVAL, NVEC, 'EVAL', 'GETMIX') + CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'GETMIX') + CALL ALLOC (IVEC, NVEC, 'IVEC', 'GETMIX') + CALL ALLOC (IATJPO, NVEC, 'IATJPO', 'GETMIX') + CALL ALLOC (IASPAR, NVEC, 'IASPAR', 'GETMIX') ! ! These arrays are deallocated in mcp ! - READ (IK) (IVEC(I),I=1,NVEC) + READ (IK) (IVEC(I),I=1,NVEC) ! READ (IK) (IATJPO(I),IASPAR(I),I = 1,NVEC) - IATJPO(:NVEC) = IATJP - IASPAR(:NVEC) = IASPA - READ (IK) EAV, (EVAL(I),I=1,NVEC) - READ (IK) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + IATJPO(:NVEC) = IATJP + IASPAR(:NVEC) = IASPA + READ (IK) EAV, (EVAL(I),I=1,NVEC) + READ (IK) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) ! - WRITE (6, *) ' ... load complete;' + WRITE (6, *) ' ... load complete;' ! ! Close the rscf.mix file ! ! CLOSE (IK) ! - RETURN + RETURN END SUBROUTINE GETMIX diff --git a/src/appl/rbiotransform90_mpi/getmixmpi_I.f90 b/src/appl/rbiotransform90_mpi/getmixmpi_I.f90 index 4329211cf..c46f9f750 100644 --- a/src/appl/rbiotransform90_mpi/getmixmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/getmixmpi_I.f90 @@ -1,12 +1,12 @@ - MODULE getmix_I + MODULE getmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getmix (NAME, INPCI, IBLK) - CHARACTER (LEN = 128), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: INPCI - INTEGER, INTENT(IN) :: IBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getmix (NAME, INPCI, IBLK) + CHARACTER (LEN = 128), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: INPCI + INTEGER, INTENT(IN) :: IBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/getsmpi.f90 b/src/appl/rbiotransform90_mpi/getsmpi.f90 index 89dcf4bc8..a795d764b 100644 --- a/src/appl/rbiotransform90_mpi/getsmpi.f90 +++ b/src/appl/rbiotransform90_mpi/getsmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETS(S, NSHLI, NSHLF) + SUBROUTINE GETS(S, NSHLI, NSHLF) ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE GETS(S, NSHLI, NSHLF) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE orb_C @@ -24,53 +24,53 @@ SUBROUTINE GETS(S, NSHLI, NSHLF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I - USE wrtmat_I + USE quad_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NSHLI - INTEGER :: NSHLF - REAL(DOUBLE) :: S(NSHLI,NSHLF) + INTEGER :: NSHLI + INTEGER :: NSHLF + REAL(DOUBLE) :: S(NSHLI,NSHLF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! - DO I = 1, NSHLI - DO J = 1, NSHLF + DO I = 1, NSHLI + DO J = 1, NSHLF ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.D0 - DO L = 2, MTP + TA(1) = 0.D0 + DO L = 2, MTP TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - S(I,J) = RESULT - END DO - END DO + CALL QUAD (RESULT) + S(I,J) = RESULT + END DO + END DO ! ! Print out ! if (myid .eq. 0) then -! WRITE (*, *) '********************' -! WRITE (*, *) ' S matrix from GETS' -! WRITE (*, *) '********************' - - CALL WRTMAT (S, NSHLI, NSHLF, NSHLI, NSHLF) +! WRITE (*, *) '********************' +! WRITE (*, *) ' S matrix from GETS' +! WRITE (*, *) '********************' + + CALL WRTMAT (S, NSHLI, NSHLF, NSHLI, NSHLF) endif ! - RETURN + RETURN END SUBROUTINE GETS diff --git a/src/appl/rbiotransform90_mpi/getsmpi_I.f90 b/src/appl/rbiotransform90_mpi/getsmpi_I.f90 index da978da1e..7b7cc88d9 100644 --- a/src/appl/rbiotransform90_mpi/getsmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/getsmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE gets_I + MODULE gets_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE gets (S, NSHLI, NSHLF) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NSHLI,NSHLF), INTENT(OUT) :: S - INTEGER, INTENT(IN) :: NSHLI - INTEGER, INTENT(IN) :: NSHLF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE gets (S, NSHLI, NSHLF) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NSHLI,NSHLF), INTENT(OUT) :: S + INTEGER, INTENT(IN) :: NSHLI + INTEGER, INTENT(IN) :: NSHLF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/ielsum.f90 b/src/appl/rbiotransform90_mpi/ielsum.f90 index 793b6a0c2..c9431aecf 100644 --- a/src/appl/rbiotransform90_mpi/ielsum.f90 +++ b/src/appl/rbiotransform90_mpi/ielsum.f90 @@ -3,33 +3,33 @@ ! I E L S U M ! ------------------------------------------------------------------ ! - INTEGER FUNCTION IELSUM (IVEC, NELMNT) + INTEGER FUNCTION IELSUM (IVEC, NELMNT) ! ! Sum elements of integer array ! -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NELMNT - INTEGER, INTENT(IN) :: IVEC(*) + INTEGER, INTENT(IN) :: NELMNT + INTEGER, INTENT(IN) :: IVEC(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISUM, IEL + INTEGER :: ISUM, IEL !----------------------------------------------- ! - ISUM = 0 - ISUM = SUM(IVEC(:NELMNT)) + ISUM = 0 + ISUM = SUM(IVEC(:NELMNT)) ! - IELSUM = ISUM + IELSUM = ISUM ! - RETURN - END FUNCTION IELSUM + RETURN + END FUNCTION IELSUM diff --git a/src/appl/rbiotransform90_mpi/ielsum_I.f90 b/src/appl/rbiotransform90_mpi/ielsum_I.f90 index fc1e39205..aa0fc51f4 100644 --- a/src/appl/rbiotransform90_mpi/ielsum_I.f90 +++ b/src/appl/rbiotransform90_mpi/ielsum_I.f90 @@ -1,11 +1,11 @@ - MODULE ielsum_I + MODULE ielsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ielsum (IVEC, NELMNT) - INTEGER, DIMENSION(*), INTENT(IN) :: IVEC - INTEGER, INTENT(IN) :: NELMNT - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ielsum (IVEC, NELMNT) + INTEGER, DIMENSION(*), INTENT(IN) :: IVEC + INTEGER, INTENT(IN) :: NELMNT + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/ifnmnx.f90 b/src/appl/rbiotransform90_mpi/ifnmnx.f90 index ee2c8fa47..0d5e6f3ad 100644 --- a/src/appl/rbiotransform90_mpi/ifnmnx.f90 +++ b/src/appl/rbiotransform90_mpi/ifnmnx.f90 @@ -3,48 +3,48 @@ ! I F N M N X ! ------------------------------------------------------------------ ! - INTEGER FUNCTION IFNMNX (IVEC, NEL, IMXMN) + INTEGER FUNCTION IFNMNX (IVEC, NEL, IMXMN) ! ! Smallest or largest value of integer array ! ! IMXMN = 1 => Largest value ! IMXMN = 2 => Smallest ! -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NEL - INTEGER , INTENT(IN) :: IMXMN - INTEGER , INTENT(IN) :: IVEC(NEL) + INTEGER , INTENT(IN) :: NEL + INTEGER , INTENT(IN) :: IMXMN + INTEGER , INTENT(IN) :: IVEC(NEL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IVAL, IEL, NTEST + INTEGER :: IVAL, IEL, NTEST !----------------------------------------------- ! - IVAL = IVEC(1) - IF (IMXMN == 1) THEN - IVAL = MAX0(MAXVAL(IVEC(2:NEL)),IVAL) - ELSE IF (IMXMN == 2) THEN - IVAL = MIN0(MINVAL(IVEC(2:NEL)),IVAL) - ELSE - WRITE (6, *) ' Stop in IFNMNX ' - WRITE (6, *) ' Improper calue of IMXMN ', IMXMN - STOP 'IFNMNX' - ENDIF + IVAL = IVEC(1) + IF (IMXMN == 1) THEN + IVAL = MAX0(MAXVAL(IVEC(2:NEL)),IVAL) + ELSE IF (IMXMN == 2) THEN + IVAL = MIN0(MINVAL(IVEC(2:NEL)),IVAL) + ELSE + WRITE (6, *) ' Stop in IFNMNX ' + WRITE (6, *) ' Improper calue of IMXMN ', IMXMN + STOP 'IFNMNX' + ENDIF ! - IFNMNX = IVAL + IFNMNX = IVAL ! - NTEST = 0 - IF (NTEST /= 0) WRITE (6, *) ' Value returned from IFNMNX', IFNMNX + NTEST = 0 + IF (NTEST /= 0) WRITE (6, *) ' Value returned from IFNMNX', IFNMNX ! - RETURN - END FUNCTION IFNMNX + RETURN + END FUNCTION IFNMNX diff --git a/src/appl/rbiotransform90_mpi/ifnmnx_I.f90 b/src/appl/rbiotransform90_mpi/ifnmnx_I.f90 index 5437d5c1d..49e4bee9b 100644 --- a/src/appl/rbiotransform90_mpi/ifnmnx_I.f90 +++ b/src/appl/rbiotransform90_mpi/ifnmnx_I.f90 @@ -1,13 +1,13 @@ - MODULE ifnmnx_I + MODULE ifnmnx_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ifnmnx (IVEC, NEL, IMXMN) - INTEGER, DIMENSION(NEL), INTENT(IN) :: IVEC - INTEGER, INTENT(IN) :: NEL - INTEGER, INTENT(IN) :: IMXMN + INTEGER FUNCTION ifnmnx (IVEC, NEL, IMXMN) + INTEGER, DIMENSION(NEL), INTENT(IN) :: IVEC + INTEGER, INTENT(IN) :: NEL + INTEGER, INTENT(IN) :: IMXMN !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/inprod.f90 b/src/appl/rbiotransform90_mpi/inprod.f90 index fd2649997..211d8f507 100644 --- a/src/appl/rbiotransform90_mpi/inprod.f90 +++ b/src/appl/rbiotransform90_mpi/inprod.f90 @@ -3,30 +3,30 @@ ! I N P R O D ! ------------------------------------------------------------------ ! - REAL(KIND(0.0D0)) FUNCTION INPROD (A, B, NDIM) + REAL(KIND(0.0D0)) FUNCTION INPROD (A, B, NDIM) ! CALCULATE SCALAR PRODUCT BETWEEN TO VECTORS A,B !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(*) - REAL(DOUBLE), INTENT(IN) :: B(*) + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(*) + REAL(DOUBLE), INTENT(IN) :: B(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! - INPROD = DOT_PRODUCT(A(:NDIM),B(:NDIM)) + INPROD = DOT_PRODUCT(A(:NDIM),B(:NDIM)) ! - RETURN - END FUNCTION INPROD + RETURN + END FUNCTION INPROD diff --git a/src/appl/rbiotransform90_mpi/inprod_I.f90 b/src/appl/rbiotransform90_mpi/inprod_I.f90 index 7a11c9e2e..0cfed6dde 100644 --- a/src/appl/rbiotransform90_mpi/inprod_I.f90 +++ b/src/appl/rbiotransform90_mpi/inprod_I.f90 @@ -1,13 +1,13 @@ - MODULE inprod_I + MODULE inprod_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION inprod (A, B, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: B - INTEGER, INTENT(IN) :: NDIM - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION inprod (A, B, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: B + INTEGER, INTENT(IN) :: NDIM + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/intrpqf.f90 b/src/appl/rbiotransform90_mpi/intrpqf.f90 index bf20a798a..a24048493 100644 --- a/src/appl/rbiotransform90_mpi/intrpqf.f90 +++ b/src/appl/rbiotransform90_mpi/intrpqf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) + SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! * ! This subprogram interpolates the arrays PA(1:MA), QA(1:MA), * ! tabulated on grid RA(1:MA) into the COMMON arrays PF(1:MF(J),J), * @@ -13,15 +13,15 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! Written by Farid A Parpia, at Oxford Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEBUG_C + USE DEBUG_C USE biorb_C USE orb_C USE def_C, ONLY:accy @@ -30,32 +30,32 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rintff_I + USE rintff_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MA - INTEGER :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + INTEGER, INTENT(IN) :: MA + INTEGER :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 13 + INTEGER, PARAMETER :: MXORD = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, MFJ, NRSTLO, KOUNT, IROW, K, NRSTHI, LLO, LHI, LOCNXT, & - ILIROK, ILDIAG, ILOTHR, MFJP1 - REAL(DOUBLE), DIMENSION(MXORD) :: X, DX - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ + ILIROK, ILDIAG, ILOTHR, MFJP1 + REAL(DOUBLE), DIMENSION(MXORD) :: X, DX + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ REAL(DOUBLE) :: RAMA, RN, XBAR, PESTL, QESTL, DIFF, DIFFT, DXKMN1, DXIROW& - , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC - LOGICAL :: SET - LOGICAL, DIMENSION(NNNP) :: USED + , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC + LOGICAL :: SET + LOGICAL, DIMENSION(NNNP) :: USED !----------------------------------------------- ! ! MXORD is the maximum order of the interpolation @@ -67,177 +67,177 @@ SUBROUTINE INTRPQF(PA, QA, MA, RA, J, DNORM) ! ! Initialization ! - RAMA = RA(MA) - RN = R(N) + RAMA = RA(MA) + RN = R(N) ! ! This is always true in GRASP ! - PFFF(1,J) = 0.0D00 - QFFF(1,J) = 0.0D00 + PFFF(1,J) = 0.0D00 + QFFF(1,J) = 0.0D00 ! ! Checks ! - IF (RAMA > RN) THEN - WRITE (*, 300) RN, RAMA - STOP - ENDIF + IF (RAMA > RN) THEN + WRITE (*, 300) RN, RAMA + STOP + ENDIF ! ! Determine end of grid ! - I = N - 1 CONTINUE - I = I - 1 - IF (R(I) <= RAMA) THEN - MFJ = I - ELSE - GO TO 1 - ENDIF - MFFF(J) = MFJ + I = N + 1 CONTINUE + I = I - 1 + IF (R(I) <= RAMA) THEN + MFJ = I + ELSE + GO TO 1 + ENDIF + MFFF(J) = MFJ ! ! Overall initialization for interpolation ! - NRSTLO = 0 - KOUNT = 0 + NRSTLO = 0 + KOUNT = 0 ! ! Perform interpolation ! - DO I = 2, MFJ + DO I = 2, MFJ ! ! Initialization for interpolation ! - XBAR = R(I) - IROW = 0 - PESTL = 0.0D00 - QESTL = 0.0D00 + XBAR = R(I) + IROW = 0 + PESTL = 0.0D00 + QESTL = 0.0D00 ! ! Determine the nearest two grid points bounding the present ! grid point ! - 2 CONTINUE - K = NRSTLO + 1 - IF (RA(K) < XBAR) THEN - NRSTLO = K - GO TO 2 - ELSE - NRSTHI = K - ENDIF + 2 CONTINUE + K = NRSTLO + 1 + IF (RA(K) < XBAR) THEN + NRSTLO = K + GO TO 2 + ELSE + NRSTHI = K + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,MA) - USED(LLO:LHI) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,MA) + USED(LLO:LHI) = .FALSE. ! ! Determine next-nearest grid point ! - 4 CONTINUE - IROW = IROW + 1 - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,MA) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K)) CYCLE - IF (.NOT.SET) THEN - DIFF = RA(K) - XBAR - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = RA(K) - XBAR - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT) = .TRUE. - X(IROW) = RA(LOCNXT) - DX(IROW) = DIFF + 4 CONTINUE + IROW = IROW + 1 + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,MA) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K)) CYCLE + IF (.NOT.SET) THEN + DIFF = RA(K) - XBAR + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = RA(K) - XBAR + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT) = .TRUE. + X(IROW) = RA(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLYP(ILIROK) = PA(LOCNXT) - POLYQ(ILIROK) = QA(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) - DXKMN1 = DX(K-1) - DXIROW = DX(IROW) - FACTOR = 1.0D00/(X(IROW)-X(K-1)) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLYP(ILIROK) = PA(LOCNXT) + POLYQ(ILIROK) = QA(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) + DXKMN1 = DX(K-1) + DXIROW = DX(IROW) + FACTOR = 1.0D00/(X(IROW)-X(K-1)) POLYP(ILIROK) = (POLYP(ILDIAG)*DXIROW-POLYP(ILOTHR)*DXKMN1)*& - FACTOR + FACTOR POLYQ(ILIROK) = (POLYQ(ILDIAG)*DXIROW-POLYQ(ILOTHR)*DXKMN1)*& - FACTOR - ENDIF - END DO + FACTOR + ENDIF + END DO ! ! Check for convergence ! - ILDIAG = ILOC(IROW,IROW) - PESTT = POLYP(ILDIAG) - QESTT = POLYQ(ILDIAG) - IF (PESTT==0.0D00 .OR. QESTT==0.0D00) THEN - IF (IROW < MXORD) THEN - GO TO 4 - ELSE - PFFF(I,J) = PESTT - QFFF(I,J) = QESTT - ENDIF - ELSE - DPBP = ABS((PESTT - PESTL)/PESTT) - DQBQ = ABS((QESTT - QESTL)/QESTT) - IF (DQBQ0) WRITE (99, 301) ACCY, KOUNT, MFJ + IF (LDBPR(3) .AND. KOUNT>0) WRITE (99, 301) ACCY, KOUNT, MFJ ! ! Normalization ! - DNORM = RINTFF(J,J,0) - DNFAC = 1.0D00/SQRT(DNORM) - PFFF(:MFJ,J) = PFFF(:MFJ,J)*DNFAC - QFFF(:MFJ,J) = QFFF(:MFJ,J)*DNFAC + DNORM = RINTFF(J,J,0) + DNFAC = 1.0D00/SQRT(DNORM) + PFFF(:MFJ,J) = PFFF(:MFJ,J)*DNFAC + QFFF(:MFJ,J) = QFFF(:MFJ,J)*DNFAC ! - RETURN + RETURN ! 300 FORMAT(/,'INTRPQ: Grid of insufficient extent:'/,& ' Present grid has R(N) = ',1P,1D19.12,' Bohr radii'/,& - ' Require R(N) = ',1D19.12,' Bohr radii') + ' Require R(N) = ',1D19.12,' Bohr radii') 301 FORMAT(/,'INTRPQ: Interpolation procedure not converged to',1P,1D19.12,& - ' for ',1I3,' of ',1I3,' tabulation points') - RETURN - CONTAINS + ' for ',1I3,' of ',1I3,' tabulation points') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTRPQF + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTRPQF diff --git a/src/appl/rbiotransform90_mpi/intrpqf_I.f90 b/src/appl/rbiotransform90_mpi/intrpqf_I.f90 index 17b2df422..aba8ba1d3 100644 --- a/src/appl/rbiotransform90_mpi/intrpqf_I.f90 +++ b/src/appl/rbiotransform90_mpi/intrpqf_I.f90 @@ -1,16 +1,16 @@ - MODULE intrpqf_I + MODULE intrpqf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE intrpqf (PA, QA, MA, RA, J, DNORM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA - INTEGER, INTENT(IN) :: MA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE intrpqf (PA, QA, MA, RA, J, DNORM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA + INTEGER, INTENT(IN) :: MA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/intrpqi.f90 b/src/appl/rbiotransform90_mpi/intrpqi.f90 index d68a727eb..ea1119ea0 100644 --- a/src/appl/rbiotransform90_mpi/intrpqi.f90 +++ b/src/appl/rbiotransform90_mpi/intrpqi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) + SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! * ! This subprogram interpolates the arrays PA(1:MA), QA(1:MA), * ! tabulated on grid RA(1:MA) into the COMMON arrays PF(1:MF(J),J), * @@ -13,45 +13,45 @@ SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! Written by Farid A Parpia, at Oxford Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEBUG_C + USE DEBUG_C USE def_C, ONLY: accy USE grid_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rintii_I + USE rintii_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MA - INTEGER :: J - REAL(DOUBLE) , INTENT(OUT) :: DNORM + INTEGER, INTENT(IN) :: MA + INTEGER :: J + REAL(DOUBLE) , INTENT(OUT) :: DNORM REAL(DOUBLE) , DIMENSION(*), INTENT(IN) :: pa, qa, ra !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 13 + INTEGER, PARAMETER :: MXORD = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, MFJ, NRSTLO, KOUNT, IROW, K, NRSTHI, LLO, LHI, LOCNXT, & - ILIROK, ILDIAG, ILOTHR, MFJP1 - REAL(DOUBLE), DIMENSION(MXORD) :: X, DX - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ + ILIROK, ILDIAG, ILOTHR, MFJP1 + REAL(DOUBLE), DIMENSION(MXORD) :: X, DX + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ REAL(DOUBLE) :: RAMA, RN, XBAR, PESTL, QESTL, DIFF, DIFFT, DXKMN1, DXIROW& - , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC - LOGICAL :: SET - LOGICAL, DIMENSION(NNNP) :: USED + , FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC + LOGICAL :: SET + LOGICAL, DIMENSION(NNNP) :: USED !----------------------------------------------- ! ! MXORD is the maximum order of the interpolation @@ -62,178 +62,178 @@ SUBROUTINE INTRPQI(PA, QA, MA, RA, J, DNORM) ! ! Initialization ! - RAMA = RA(MA) - RN = R(N) + RAMA = RA(MA) + RN = R(N) ! ! This is always true in GRASP ! - PFII(1,J) = 0.0D00 - QFII(1,J) = 0.0D00 + PFII(1,J) = 0.0D00 + QFII(1,J) = 0.0D00 ! ! Checks ! - IF (RAMA > RN) THEN - WRITE (*, 300) RN, RAMA - STOP - ENDIF + IF (RAMA > RN) THEN + WRITE (*, 300) RN, RAMA + STOP + ENDIF ! ! Determine end of grid ! - I = N - 1 CONTINUE - I = I - 1 - IF (R(I) <= RAMA) THEN - MFJ = I - ELSE - GO TO 1 - ENDIF - MFII(J) = MFJ + I = N + 1 CONTINUE + I = I - 1 + IF (R(I) <= RAMA) THEN + MFJ = I + ELSE + GO TO 1 + ENDIF + MFII(J) = MFJ ! ! Overall initialization for interpolation ! - NRSTLO = 0 - KOUNT = 0 + NRSTLO = 0 + KOUNT = 0 ! ! Perform interpolation ! - DO I = 2, MFJ + DO I = 2, MFJ ! ! Initialization for interpolation ! - XBAR = R(I) - IROW = 0 - PESTL = 0.0D00 - QESTL = 0.0D00 + XBAR = R(I) + IROW = 0 + PESTL = 0.0D00 + QESTL = 0.0D00 ! ! Determine the nearest two grid points bounding the present ! grid point ! - 2 CONTINUE - K = NRSTLO + 1 - IF (RA(K) < XBAR) THEN - NRSTLO = K - GO TO 2 - ELSE - NRSTHI = K - ENDIF + 2 CONTINUE + K = NRSTLO + 1 + IF (RA(K) < XBAR) THEN + NRSTLO = K + GO TO 2 + ELSE + NRSTHI = K + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,MA) - USED(LLO:LHI) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,MA) + USED(LLO:LHI) = .FALSE. ! ! Determine next-nearest grid point ! - 4 CONTINUE - IROW = IROW + 1 - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,MA) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K)) CYCLE - IF (.NOT.SET) THEN - DIFF = RA(K) - XBAR - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = RA(K) - XBAR - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT) = .TRUE. - X(IROW) = RA(LOCNXT) - DX(IROW) = DIFF + 4 CONTINUE + IROW = IROW + 1 + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,MA) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K)) CYCLE + IF (.NOT.SET) THEN + DIFF = RA(K) - XBAR + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = RA(K) - XBAR + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT) = .TRUE. + X(IROW) = RA(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLYP(ILIROK) = PA(LOCNXT) - POLYQ(ILIROK) = QA(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) - DXKMN1 = DX(K-1) - DXIROW = DX(IROW) - FACTOR = 1.0D00/(X(IROW)-X(K-1)) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLYP(ILIROK) = PA(LOCNXT) + POLYQ(ILIROK) = QA(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) + DXKMN1 = DX(K-1) + DXIROW = DX(IROW) + FACTOR = 1.0D00/(X(IROW)-X(K-1)) POLYP(ILIROK) = (POLYP(ILDIAG)*DXIROW-POLYP(ILOTHR)*DXKMN1)*& - FACTOR + FACTOR POLYQ(ILIROK) = (POLYQ(ILDIAG)*DXIROW-POLYQ(ILOTHR)*DXKMN1)*& - FACTOR - ENDIF - END DO + FACTOR + ENDIF + END DO ! ! Check for convergence ! - ILDIAG = ILOC(IROW,IROW) - PESTT = POLYP(ILDIAG) - QESTT = POLYQ(ILDIAG) - IF (PESTT==0.0D00 .OR. QESTT==0.0D00) THEN - IF (IROW < MXORD) THEN - GO TO 4 - ELSE - PFII(I,J) = PESTT - QFII(I,J) = QESTT - ENDIF - ELSE - DPBP = ABS((PESTT - PESTL)/PESTT) - DQBQ = ABS((QESTT - QESTL)/QESTT) - IF (DQBQ0) WRITE (99, 301) ACCY, KOUNT, MFJ + IF (LDBPR(3) .AND. KOUNT>0) WRITE (99, 301) ACCY, KOUNT, MFJ ! ! Normalization ! - DNORM = RINTII(J,J,0) + DNORM = RINTII(J,J,0) !ww WRITE(92,*) 'DNORM',DNORM - DNFAC = 1.0D00/DSQRT(DNORM) - PFII(:MFJ,J) = PFII(:MFJ,J)*DNFAC - QFII(:MFJ,J) = QFII(:MFJ,J)*DNFAC + DNFAC = 1.0D00/DSQRT(DNORM) + PFII(:MFJ,J) = PFII(:MFJ,J)*DNFAC + QFII(:MFJ,J) = QFII(:MFJ,J)*DNFAC ! - RETURN + RETURN ! 300 FORMAT(/,'INTRPQ: Grid of insufficient extent:'/,& ' Present grid has R(N) = ',1P,1D19.12,' Bohr radii'/,& - ' Require R(N) = ',1D19.12,' Bohr radii') + ' Require R(N) = ',1D19.12,' Bohr radii') 301 FORMAT(/,'INTRPQ: Interpolation procedure not converged to',1P,1D19.12,& - ' for ',1I3,' of ',1I3,' tabulation points') - RETURN - CONTAINS + ' for ',1I3,' of ',1I3,' tabulation points') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTRPQI + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTRPQI diff --git a/src/appl/rbiotransform90_mpi/intrpqi_I.f90 b/src/appl/rbiotransform90_mpi/intrpqi_I.f90 index b929ed955..be14e19ec 100644 --- a/src/appl/rbiotransform90_mpi/intrpqi_I.f90 +++ b/src/appl/rbiotransform90_mpi/intrpqi_I.f90 @@ -1,16 +1,16 @@ - MODULE intrpqi_I + MODULE intrpqi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:26:14 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE intrpqi (PA, QA, MA, RA, J, DNORM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA - INTEGER, INTENT(IN) :: MA - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE intrpqi (PA, QA, MA, RA, J, DNORM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: QA + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: RA + INTEGER, INTENT(IN) :: MA + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/invmat.f90 b/src/appl/rbiotransform90_mpi/invmat.f90 index aaa4ffb67..e58055438 100644 --- a/src/appl/rbiotransform90_mpi/invmat.f90 +++ b/src/appl/rbiotransform90_mpi/invmat.f90 @@ -4,7 +4,7 @@ ! I N V M A T ! ------------------------------------------------------------------ ! - SUBROUTINE INVMAT(A, B, MATDIM, NDIM) + SUBROUTINE INVMAT(A, B, MATDIM, NDIM) ! FIND INVERSE OF MATRIX A ! INPUT : ! A : MATRIX TO BE INVERTED @@ -16,55 +16,55 @@ SUBROUTINE INVMAT(A, B, MATDIM, NDIM) ! WARNINGS ARE ISSUED IN CASE OF CONVERGENCE PROBLEMS ) ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE bndinv_I - USE wrtmat_I + USE bndinv_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: MATDIM - INTEGER :: NDIM - REAL(DOUBLE) :: A(MATDIM,MATDIM) - REAL(DOUBLE) :: B(MATDIM,MATDIM) + INTEGER :: MATDIM + INTEGER :: NDIM + REAL(DOUBLE) :: A(MATDIM,MATDIM) + REAL(DOUBLE) :: B(MATDIM,MATDIM) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ITEST, NTEST - REAL(DOUBLE) :: DETERM, EPSIL + INTEGER :: ITEST, NTEST + REAL(DOUBLE) :: DETERM, EPSIL !----------------------------------------------- ! - ITEST = 0 - IF (NDIM == 1) THEN - IF (A(1,1) /= 0.0D0) THEN - A(1,1) = 1.0D0/A(1,1) - ELSE - ITEST = 1 - ENDIF - ELSE - DETERM = 0.0D0 - EPSIL = 0.0D0 - CALL BNDINV (A, B, NDIM, DETERM, EPSIL, ITEST, MATDIM) - ENDIF + ITEST = 0 + IF (NDIM == 1) THEN + IF (A(1,1) /= 0.0D0) THEN + A(1,1) = 1.0D0/A(1,1) + ELSE + ITEST = 1 + ENDIF + ELSE + DETERM = 0.0D0 + EPSIL = 0.0D0 + CALL BNDINV (A, B, NDIM, DETERM, EPSIL, ITEST, MATDIM) + ENDIF ! IF (ITEST /= 0) THEN - WRITE (6, '(A,I3)') ' INVERSION PROBLEM NUMBER..', ITEST + WRITE (6, '(A,I3)') ' INVERSION PROBLEM NUMBER..', ITEST STOP ENDIF - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' INVERTED MATRIX ' - CALL WRTMAT (A, NDIM, NDIM, MATDIM, MATDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' INVERTED MATRIX ' + CALL WRTMAT (A, NDIM, NDIM, MATDIM, MATDIM) + ENDIF ! - RETURN - END SUBROUTINE INVMAT + RETURN + END SUBROUTINE INVMAT diff --git a/src/appl/rbiotransform90_mpi/invmat_I.f90 b/src/appl/rbiotransform90_mpi/invmat_I.f90 index cb07bfa30..f0b15591a 100644 --- a/src/appl/rbiotransform90_mpi/invmat_I.f90 +++ b/src/appl/rbiotransform90_mpi/invmat_I.f90 @@ -1,14 +1,14 @@ - MODULE invmat_I + MODULE invmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE invmat (A, B, MATDIM, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(MATDIM,MATDIM), INTENT(INOUT) :: A - REAL(DOUBLE), DIMENSION(MATDIM,MATDIM) :: B - INTEGER, INTENT(IN) :: MATDIM - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE invmat (A, B, MATDIM, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(MATDIM,MATDIM), INTENT(INOUT) :: A + REAL(DOUBLE), DIMENSION(MATDIM,MATDIM) :: B + INTEGER, INTENT(IN) :: MATDIM + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/kapdata.f90 b/src/appl/rbiotransform90_mpi/kapdata.f90 index 7dd7392bc..0333856df 100644 --- a/src/appl/rbiotransform90_mpi/kapdata.f90 +++ b/src/appl/rbiotransform90_mpi/kapdata.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) + SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! * ! This subroutine determines the number of kappa quantum numbers * ! KAMAX together with the number of orbitals of each kappa. * @@ -12,8 +12,8 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:44 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:26:44 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -38,168 +38,168 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NTESTG - INTEGER , INTENT(IN) :: NCORE1 - INTEGER , INTENT(IN) :: NCORE2 + INTEGER , INTENT(IN) :: NTESTG + INTEGER , INTENT(IN) :: NCORE1 + INTEGER , INTENT(IN) :: NCORE2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1 - INTEGER, DIMENSION(2*NNNW) :: ISORT - INTEGER :: NTESTL, NTEST, I, J, K, ITAL, NREF - LOGICAL :: KLAR + INTEGER :: J1 + INTEGER, DIMENSION(2*NNNW) :: ISORT + INTEGER :: NTESTL, NTEST, I, J, K, ITAL, NREF + LOGICAL :: KLAR !----------------------------------------------- ! ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - - ISORT(:2*NNNW) = 100 - - IKAPPA(:NLMAX) = 0 - NSHLII(:NLMAX) = 0 - NSHLFF(:NLMAX) = 0 - NINII(:NLMAX) = 0 - NINFF(:NLMAX) = 0 - - NAKINVII(:NNNW) = 0 - NAKINVFF(:NNNW) = 0 - - NSHLPII(:NLMAX,:NLMAX) = 0 - NSHLPFF(:NLMAX,:NLMAX) = 0 - - NSHLPPII(:NLMAX,:NNNW) = 0 - NSHLPPFF(:NLMAX,:NNNW) = 0 + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + + ISORT(:2*NNNW) = 100 + + IKAPPA(:NLMAX) = 0 + NSHLII(:NLMAX) = 0 + NSHLFF(:NLMAX) = 0 + NINII(:NLMAX) = 0 + NINFF(:NLMAX) = 0 + + NAKINVII(:NNNW) = 0 + NAKINVFF(:NNNW) = 0 + + NSHLPII(:NLMAX,:NLMAX) = 0 + NSHLPFF(:NLMAX,:NLMAX) = 0 + + NSHLPPII(:NLMAX,:NNNW) = 0 + NSHLPPFF(:NLMAX,:NNNW) = 0 ! ! Sort the kappa quantum numbers ! - DO K = 1, NWII + NWFF - IF (K <= NWII) THEN - ITAL = NAKII(K) - ELSE - ITAL = NAKFF(K-NWII) - ENDIF - I = K - 1 - KLAR = .FALSE. - 12 CONTINUE - IF (I>0 .AND. .NOT.KLAR) THEN - IF (ITAL <= ISORT(I)) THEN - ISORT(I+1) = ISORT(I) - I = I - 1 - ELSE - KLAR = .TRUE. - ENDIF - GO TO 12 - ENDIF - ISORT(I+1) = ITAL - END DO + DO K = 1, NWII + NWFF + IF (K <= NWII) THEN + ITAL = NAKII(K) + ELSE + ITAL = NAKFF(K-NWII) + ENDIF + I = K - 1 + KLAR = .FALSE. + 12 CONTINUE + IF (I>0 .AND. .NOT.KLAR) THEN + IF (ITAL <= ISORT(I)) THEN + ISORT(I+1) = ISORT(I) + I = I - 1 + ELSE + KLAR = .TRUE. + ENDIF + GO TO 12 + ENDIF + ISORT(I+1) = ITAL + END DO ! ! Determine the unique set of kappa IKAPPA ! - KAMAX = 1 - IKAPPA(1) = ISORT(1) - DO K = 1, 2*NNNW - 1 - IF (ISORT(K)==ISORT(K+1) .OR. ISORT(K+1)>=100) CYCLE - KAMAX = KAMAX + 1 - IKAPPA(KAMAX) = ISORT(K+1) - END DO + KAMAX = 1 + IKAPPA(1) = ISORT(1) + DO K = 1, 2*NNNW - 1 + IF (ISORT(K)==ISORT(K+1) .OR. ISORT(K+1)>=100) CYCLE + KAMAX = KAMAX + 1 + IKAPPA(KAMAX) = ISORT(K+1) + END DO ! ! Make a connection between each kappa and a number in the ! range [1,KAMAX] as to know on which file to dump the data ! Determine the number of shells NSHLII for each I in the ! range [1,KAMAX] ! - IF (NTEST >= 10) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering kapdata' - WRITE (*, *) '******************' - WRITE (*, *) - WRITE (*, *) 'There are', NWII, 'orbitals in the initial state' - WRITE (*, *) 'with the following n and kappa quantum numbers' - ENDIF - - DO J = 1, NWII + IF (NTEST >= 10) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering kapdata' + WRITE (*, *) '******************' + WRITE (*, *) + WRITE (*, *) 'There are', NWII, 'orbitals in the initial state' + WRITE (*, *) 'with the following n and kappa quantum numbers' + ENDIF + + DO J = 1, NWII IF (NTEST >= 10) WRITE (*, *) 'orbital number', J, 'n and kappa', NPII& - (J), NAKII(J) - IF (J <= NCORE1) THEN - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKII(J)) CYCLE - NAKINVII(J) = I - NINII(I) = NINII(I) + 1 - NSHLII(I) = NSHLII(I) + 1 - NSHLPII(I,NSHLII(I)) = J - NSHLPPII(I,J) = NSHLII(I) - END DO - ELSE - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKII(J)) CYCLE - NAKINVII(J) = I - NSHLII(I) = NSHLII(I) + 1 - NSHLPII(I,NSHLII(I)) = J - NSHLPPII(I,J) = NSHLII(I) - END DO - ENDIF - END DO - - IF (NTEST >= 10) THEN - WRITE (*, *) 'There are', NWFF, 'orbitals in the final state' - WRITE (*, *) 'with the following n and kappa quantum numbers' - ENDIF - DO J = 1, NWFF + (J), NAKII(J) + IF (J <= NCORE1) THEN + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKII(J)) CYCLE + NAKINVII(J) = I + NINII(I) = NINII(I) + 1 + NSHLII(I) = NSHLII(I) + 1 + NSHLPII(I,NSHLII(I)) = J + NSHLPPII(I,J) = NSHLII(I) + END DO + ELSE + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKII(J)) CYCLE + NAKINVII(J) = I + NSHLII(I) = NSHLII(I) + 1 + NSHLPII(I,NSHLII(I)) = J + NSHLPPII(I,J) = NSHLII(I) + END DO + ENDIF + END DO + + IF (NTEST >= 10) THEN + WRITE (*, *) 'There are', NWFF, 'orbitals in the final state' + WRITE (*, *) 'with the following n and kappa quantum numbers' + ENDIF + DO J = 1, NWFF IF (NTEST >= 10) WRITE (*, *) 'orbital number', J, 'n and kappa=', & - NPFF(J), NAKFF(J) - IF (J <= NCORE2) THEN - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKFF(J)) CYCLE - NAKINVFF(J) = I - NINFF(I) = NINFF(I) + 1 - NSHLFF(I) = NSHLFF(I) + 1 - NSHLPFF(I,NSHLFF(I)) = J - NSHLPPFF(I,J) = NSHLFF(I) - END DO - ELSE - DO I = 1, KAMAX - IF (IKAPPA(I) /= NAKFF(J)) CYCLE - NAKINVFF(J) = I - NSHLFF(I) = NSHLFF(I) + 1 - NSHLPFF(I,NSHLFF(I)) = J - NSHLPPFF(I,J) = NSHLFF(I) - END DO - ENDIF - END DO - - IF (NTEST >= 10) THEN - WRITE (*, *) 'Total number of different kappa', KAMAX - DO I = 1, KAMAX - WRITE (*, *) 'L=', I, 'corresponds to kappa=', IKAPPA(I) - WRITE (*, *) 'nr of init. orb. with this kappa=', NSHLII(I) - WRITE (*, *) 'nr of final. orb. with this kappa=', NSHLFF(I) - END DO - DO I = 1, KAMAX - WRITE (*, *) 'Position in initial state list' - DO J = 1, NSHLII(I) - WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPII(I,J) - END DO - WRITE (*, *) 'Position in final state list' - DO J = 1, NSHLFF(I) - WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPFF(I,J) - END DO - WRITE (*, *) 'Relative positions for initial state orbitals' - DO J = 1, NWII - IF (NSHLPPII(I,J) == 0) CYCLE + NPFF(J), NAKFF(J) + IF (J <= NCORE2) THEN + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKFF(J)) CYCLE + NAKINVFF(J) = I + NINFF(I) = NINFF(I) + 1 + NSHLFF(I) = NSHLFF(I) + 1 + NSHLPFF(I,NSHLFF(I)) = J + NSHLPPFF(I,J) = NSHLFF(I) + END DO + ELSE + DO I = 1, KAMAX + IF (IKAPPA(I) /= NAKFF(J)) CYCLE + NAKINVFF(J) = I + NSHLFF(I) = NSHLFF(I) + 1 + NSHLPFF(I,NSHLFF(I)) = J + NSHLPPFF(I,J) = NSHLFF(I) + END DO + ENDIF + END DO + + IF (NTEST >= 10) THEN + WRITE (*, *) 'Total number of different kappa', KAMAX + DO I = 1, KAMAX + WRITE (*, *) 'L=', I, 'corresponds to kappa=', IKAPPA(I) + WRITE (*, *) 'nr of init. orb. with this kappa=', NSHLII(I) + WRITE (*, *) 'nr of final. orb. with this kappa=', NSHLFF(I) + END DO + DO I = 1, KAMAX + WRITE (*, *) 'Position in initial state list' + DO J = 1, NSHLII(I) + WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPII(I,J) + END DO + WRITE (*, *) 'Position in final state list' + DO J = 1, NSHLFF(I) + WRITE (*, *) 'L=', I, 'orb. nr', J, ',position', NSHLPFF(I,J) + END DO + WRITE (*, *) 'Relative positions for initial state orbitals' + DO J = 1, NWII + IF (NSHLPPII(I,J) == 0) CYCLE WRITE (*, *) 'Orbital', J, 'is nr', NSHLPPII(I,J), 'with kappa'& - , IKAPPA(I) - END DO - WRITE (*, *) 'Relative positions for final state orbitals' - DO J = 1, NWFF - IF (NSHLPPFF(I,J) == 0) CYCLE + , IKAPPA(I) + END DO + WRITE (*, *) 'Relative positions for final state orbitals' + DO J = 1, NWFF + IF (NSHLPPFF(I,J) == 0) CYCLE WRITE (*, *) 'Orbital', J, 'is nr', NSHLPPFF(I,J), 'with kappa'& - , IKAPPA(I) - END DO - END DO - - ENDIF + , IKAPPA(I) + END DO + END DO + + ENDIF ! ! Check if the orbital ordering is normal or reversed. ! @@ -211,70 +211,70 @@ SUBROUTINE KAPDATA(NTESTG, NCORE1, NCORE2) ! ! NPII(NSHLPII(I,1)) > NPII(NSHLPII(I,2)) > ... > NPII(NSHLPII(I,NSHLII(I)) ! - NORDII = 0 - DO I = 1, KAMAX - NREF = 0 - DO J = 1 + NINII(I), NSHLII(I) - IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 1 - NREF = NPII(NSHLPII(I,J)) - END DO - END DO - - NORDFF = 0 - DO I = 1, KAMAX - NREF = 0 - DO J = 1 + NINFF(I), NSHLFF(I) - IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 1 - NREF = NPFF(NSHLPFF(I,J)) - END DO - END DO - - IF (NORDII /= NORDFF) THEN - WRITE (*, *) ' Orbital order of the initial and final states' - WRITE (*, *) ' should be the same. STOP' - STOP - ENDIF + NORDII = 0 + DO I = 1, KAMAX + NREF = 0 + DO J = 1 + NINII(I), NSHLII(I) + IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 1 + NREF = NPII(NSHLPII(I,J)) + END DO + END DO + + NORDFF = 0 + DO I = 1, KAMAX + NREF = 0 + DO J = 1 + NINFF(I), NSHLFF(I) + IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 1 + NREF = NPFF(NSHLPFF(I,J)) + END DO + END DO + + IF (NORDII /= NORDFF) THEN + WRITE (*, *) ' Orbital order of the initial and final states' + WRITE (*, *) ' should be the same. STOP' + STOP + ENDIF ! ! If not normal order check if reversed order ! - IF (NORDII == 1) THEN - DO I = 1, KAMAX - NREF = 0 - DO J = NSHLII(I), 1 + NINII(I), -1 - IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 2 - NREF = NPII(NSHLPII(I,J)) - END DO - END DO - - DO I = 1, KAMAX - NREF = 0 - DO J = NSHLFF(I), 1 + NINFF(I), -1 - IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 2 - NREF = NPFF(NSHLPFF(I,J)) - END DO - END DO - ENDIF - - IF (NORDII==2 .OR. NORDFF==2) THEN - WRITE (*, *) ' The orbital order is neither normal or reversed' - WRITE (*, *) ' STOP' - STOP - ENDIF - + IF (NORDII == 1) THEN + DO I = 1, KAMAX + NREF = 0 + DO J = NSHLII(I), 1 + NINII(I), -1 + IF (NPII(NSHLPII(I,J)) < NREF) NORDII = 2 + NREF = NPII(NSHLPII(I,J)) + END DO + END DO + + DO I = 1, KAMAX + NREF = 0 + DO J = NSHLFF(I), 1 + NINFF(I), -1 + IF (NPFF(NSHLPFF(I,J)) < NREF) NORDFF = 2 + NREF = NPFF(NSHLPFF(I,J)) + END DO + END DO + ENDIF + + IF (NORDII==2 .OR. NORDFF==2) THEN + WRITE (*, *) ' The orbital order is neither normal or reversed' + WRITE (*, *) ' STOP' + STOP + ENDIF + !w write(*,*) 'Give nordii' !w read(*,*) nordii !w nordff = nordii - - IF (NORDII == 0) THEN - WRITE (*, *) ' Normal orbital ordering' - ELSE - WRITE (*, *) ' Reverse orbital ordering' - ENDIF - -! WRITE (*, *) '*****************' -! WRITE (*, *) ' Leaving kapdata' -! WRITE (*, *) '*****************' -! WRITE (*, *) - - RETURN - END SUBROUTINE KAPDATA + + IF (NORDII == 0) THEN + WRITE (*, *) ' Normal orbital ordering' + ELSE + WRITE (*, *) ' Reverse orbital ordering' + ENDIF + +! WRITE (*, *) '*****************' +! WRITE (*, *) ' Leaving kapdata' +! WRITE (*, *) '*****************' +! WRITE (*, *) + + RETURN + END SUBROUTINE KAPDATA diff --git a/src/appl/rbiotransform90_mpi/kapdata_I.f90 b/src/appl/rbiotransform90_mpi/kapdata_I.f90 index db7eb181c..5135e26ad 100644 --- a/src/appl/rbiotransform90_mpi/kapdata_I.f90 +++ b/src/appl/rbiotransform90_mpi/kapdata_I.f90 @@ -1,12 +1,12 @@ - MODULE kapdata_I + MODULE kapdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE kapdata (NTESTG, NCORE1, NCORE2) - INTEGER, INTENT(IN) :: NTESTG - INTEGER, INTENT(IN) :: NCORE1 - INTEGER, INTENT(IN) :: NCORE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE kapdata (NTESTG, NCORE1, NCORE2) + INTEGER, INTENT(IN) :: NTESTG + INTEGER, INTENT(IN) :: NCORE1 + INTEGER, INTENT(IN) :: NCORE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/lodcslBio.f90 b/src/appl/rbiotransform90_mpi/lodcslBio.f90 index e7d3d4e96..b871bdd18 100644 --- a/src/appl/rbiotransform90_mpi/lodcslBio.f90 +++ b/src/appl/rbiotransform90_mpi/lodcslBio.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSLBio(NCORE,IGG) + SUBROUTINE LODCSLBio(NCORE,IGG) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -15,115 +15,115 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE ORB_C + USE DEBUG_C + USE DEF_C + USE ORB_C USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C USE BLK_C, only: NBLOCK,NCFBLK USE memory_man !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER, INTENT(IN) :: IGG - INTEGER, INTENT(OUT) :: NCORE + INTEGER, INTENT(OUT) :: NCORE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: IOCC - INTEGER , DIMENSION(NW2) :: IQSUB - INTEGER , DIMENSION(NNNW) :: JX + INTEGER , DIMENSION(NNNW) :: IOCC + INTEGER , DIMENSION(NW2) :: IQSUB + INTEGER , DIMENSION(NNNW) :: JX INTEGER :: I INTEGER :: NCORP1, NPEEL, NPEEL2, J, NPJ, NAKJ, LENTH, NCFD, NREC & , IOS, IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN & , NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU & - , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECL - CHARACTER(LEN=256) :: RECORD + , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECL + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! ! Entry message ! - WRITE (6, *) 'Loading Configuration Symmetry List File ...' + WRITE (6, *) 'Loading Configuration Symmetry List File ...' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (21, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (21, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (21, *) - CALL PRSRSL (21, 2) - NPEEL = NW - NCORE - NPEEL2 = NPEEL*2 + READ (21, *) + CALL PRSRSL (21, 2) + NPEEL = NW - NCORE + NPEEL2 = NPEEL*2 ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'LODCSL: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) 'There are '//RECORD(1:LENTH)// & - ' relativistic subshells;' - ELSE - WRITE (6, *) 'There is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) 'There is 1 relativistic subshell;' + ENDIF ! ! Initial allocation for arrays with a dimension dependent ! on the number of CSFs; the initial allocation must be ! greater than 1 ! IF(IGG == 1) THEN - NCFD = 1000 + NCFD = 1000 CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSL') CALL ALLOC (JQSA, NNNW,3,NCFD, 'JQSA', 'LODCSL') CALL ALLOC (JCUPA,NNNW, NCFD, 'JCUPA', 'LODCSL') @@ -136,7 +136,7 @@ SUBROUTINE LODCSLBio(NCORE,IGG) CALL DALLOC (IQA, 'IQA', 'LODCSL') CALL DALLOC (JQSA, 'JQSA', 'LODCSL') CALL DALLOC (JCUPA, 'JCUPA', 'LODCSL') - NCFD = 1000 + NCFD = 1000 CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSL') CALL ALLOC (JQSA, NNNW,3,NCFD, 'JQSA', 'LODCSL') CALL ALLOC (JCUPA,NNNW, NCFD, 'JCUPA', 'LODCSL') @@ -145,12 +145,12 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! ! Skip the header for the list of CSFs ! - READ (21, *) + READ (21, *) ! ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -182,65 +182,65 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! These conventions have been chosen so as to render the CSF ! specifications easily interpreted by the user ! - NCF = 0 - NBLOCK = 0 - 3 CONTINUE - NCF = NCF + 1 + NCF = 0 + NBLOCK = 0 + 3 CONTINUE + NCF = NCF + 1 ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** !blk* ! To skip the border line added to mark the end of a block ! - IF (RECORD(1:2) == ' *') THEN - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -1 - READ (21, '(A)', IOSTAT=IOS) RECORD - ENDIF + IF (RECORD(1:2) == ' *') THEN + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF -1 + READ (21, '(A)', IOSTAT=IOS) RECORD + ENDIF !********************************************************************** - - IF (IOS == 0) THEN + + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting subshell quantum', & - ' number specification;' - GO TO 26 - ENDIF - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + ' number specification;' + GO TO 26 + ENDIF + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Allocate additional storage if necessary ! !CFF It is possible that this should be moved to "3 Continue" ! where NCF is incremented - IF (NCF > NCFD) THEN - NEWSIZ = NCFD + NCFD/2 + IF (NCF > NCFD) THEN + NEWSIZ = NCFD + NCFD/2 CALL RALLOC (IQA, NNNW, NEWSIZ, 'IQA', 'LODCSL') CALL RALLOC (JQSA, NNNW,3,NEWSIZ, 'JQSA', 'LODCSL') CALL RALLOC (JCUPA,NNNW, NEWSIZ, 'JCUPA', 'LODCSL') - NCFD = NEWSIZ - ENDIF + NCFD = NEWSIZ + ENDIF ! ! Zero out the arrays that store packed integers ! @@ -255,329 +255,329 @@ SUBROUTINE LODCSLBio(NCORE,IGG) ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) 'LODCSL: Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell quantum', & - ' numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + ' numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) 'LODCSL: Subshell quantum numbers ', & 'specified incorrectly for '//RECORD(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) & 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I),& - ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) 'LODCSL: Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) 'LODCSL: Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! - IF (NCF > 1) THEN - DO J = 1, NCF - 1 - DO I = NCORP1, NW - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (NCF > 1) THEN + DO J = 1, NCF - 1 + DO I = NCORP1, NW + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs; eliminating this', ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) + ' in all CSFs; eliminating this', ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL ! ! All done; report ! - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' - WRITE (6, *) ' ... load complete;' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' + WRITE (6, *) ' ... load complete;' ! ! Debug printout ! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF - - - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -! - RETURN -! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF + + + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF +! + RETURN +! + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 READ (21,'(A)',ERR = 29,END = 29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (ISTDE, *) RECORD(1:LENTH) - END DO - 29 CLOSE(21) - STOP + LENTH = LEN_TRIM(RECORD) + WRITE (ISTDE, *) RECORD(1:LENTH) + END DO + 29 CLOSE(21) + STOP ! END SUBROUTINE LODCSLBio diff --git a/src/appl/rbiotransform90_mpi/lodcslBio_I.f90 b/src/appl/rbiotransform90_mpi/lodcslBio_I.f90 index 841279907..717eb9509 100644 --- a/src/appl/rbiotransform90_mpi/lodcslBio_I.f90 +++ b/src/appl/rbiotransform90_mpi/lodcslBio_I.f90 @@ -1,11 +1,11 @@ - MODULE lodcslbio_I + MODULE lodcslbio_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcslbio (NCORE,IGG) + SUBROUTINE lodcslbio (NCORE,IGG) INTEGER, INTENT(IN) :: IGG - INTEGER, INTENT(OUT) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(OUT) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/lodrwffmpi.f90 b/src/appl/rbiotransform90_mpi/lodrwffmpi.f90 index c899b1493..f0a30e7a0 100644 --- a/src/appl/rbiotransform90_mpi/lodrwffmpi.f90 +++ b/src/appl/rbiotransform90_mpi/lodrwffmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFF(NAME, NTESTG) + SUBROUTINE LODRWFF(NAME, NTESTG) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -10,18 +10,18 @@ SUBROUTINE LODRWFF(NAME, NTESTG) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE memory_man USE biorb_C USE def_C, ONLY: z, c - USE DEBUG_C + USE DEBUG_C USE grid_C USE npar_C USE sbdat_C, ONLY: kamax, nshlff, nshlpff @@ -29,163 +29,163 @@ SUBROUTINE LODRWFF(NAME, NTESTG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE intrpqf_I + USE intrpqf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NTESTG + INTEGER, INTENT(IN) :: NTESTG CHARACTER, INTENT(IN) :: NAME*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: NAK, NP + INTEGER , DIMENSION(NNNW) :: NAK, NP INTEGER :: NTESTL, NTEST, J, K, I, NWIN, IOS, NPY, NAKY, MY, JJ, KK, JJJ& - , KKK, IERR - REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA - REAL(DOUBLE) :: CON, FKK, EY, DNORM, PZY + , KKK, IERR + REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA + REAL(DOUBLE) :: CON, FKK, EY, DNORM, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER , DIMENSION(NNNW) :: NH*2 - CHARACTER :: G92RWF*6 + CHARACTER , DIMENSION(NNNW) :: NH*2 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the final state ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - NTEST = 0 - + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + NTEST = 0 + ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for final state...' + WRITE (6, *) 'Loading Radial WaveFunction File for final state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21,FILE=NAME(1:J-1)//'.w',FORM='UNFORMATTED', & - STATUS='OLD',POSITION='asis') + STATUS='OLD',POSITION='asis') ! ! Save NAK, NP and NH ! - NAK(:NWFF) = NAKFF(:NWFF) - NP(:NWFF) = NPFF(:NWFF) - NH(:NWFF) = NHFF(:NWFF) + NAK(:NWFF) = NAKFF(:NWFF) + NP(:NWFF) = NPFF(:NWFF) + NH(:NWFF) = NHFF(:NWFF) ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFFF, NNNP,NWFF, 'PFFF', 'LODRWFF') - CALL ALLOC (QFFF, NNNP,NWFF, 'QFFF', 'LODRWF') + CALL ALLOC (PFFF, NNNP,NWFF, 'PFFF', 'LODRWFF') + CALL ALLOC (QFFF, NNNP,NWFF, 'QFFF', 'LODRWF') ! - CON = Z/C - CON = CON*CON + CON = Z/C + CON = CON*CON ! - DO J = 1, NWFF - PFFF(:NNNP,J) = 0.0D00 - QFFF(:NNNP,J) = 0.0D00 + DO J = 1, NWFF + PFFF(:NNNP,J) = 0.0D00 + QFFF(:NNNP,J) = 0.0D00 ! - K = ABS(NAK(J)) - IF (NPARM /= 0) CYCLE - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF + K = ABS(NAK(J)) + IF (NPARM /= 0) CYCLE + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF ! - END DO + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (21, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(21) - ENDIF - - IF (NTEST >= 100) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering lodrwff' - WRITE (*, *) '******************' - ENDIF - - 3 CONTINUE - READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY - IF (IOS == 0) THEN - CALL ALLOC (PA, MY, 'PA', 'LODRWFFF') - CALL ALLOC (QA, MY, 'QA', 'LODRWFFF') - CALL ALLOC (RA, MY, 'RA', 'LODRWFFF') - READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (21) (RA(I),I=1,MY) + NWIN = 0 + READ (21, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(21) + ENDIF + + IF (NTEST >= 100) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering lodrwff' + WRITE (*, *) '******************' + ENDIF + + 3 CONTINUE + READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY + IF (IOS == 0) THEN + CALL ALLOC (PA, MY, 'PA', 'LODRWFFF') + CALL ALLOC (QA, MY, 'QA', 'LODRWFFF') + CALL ALLOC (RA, MY, 'RA', 'LODRWFFF') + READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (21) (RA(I),I=1,MY) ! ! Orbital order as defined in kapdata ! - JJ = 0 - DO K = 1, KAMAX - IF (K > 1) JJ = NSHLFF(K-1) + JJ - DO J = 1, NSHLFF(K) - KK = NSHLPFF(K,J) - IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE - JJJ = JJ + J - PZFF(JJJ) = PZY - EFF(JJJ) = EY - NAKFF(JJJ) = NAK(KK) - NPFF(JJJ) = NP(KK) - NHFF(JJJ) = NH(KK) - GAMAFF(JJJ) = GAMA(KK) - CALL INTRPQF (PA, QA, MY, RA, JJJ, DNORM) + JJ = 0 + DO K = 1, KAMAX + IF (K > 1) JJ = NSHLFF(K-1) + JJ + DO J = 1, NSHLFF(K) + KK = NSHLPFF(K,J) + IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE + JJJ = JJ + J + PZFF(JJJ) = PZY + EFF(JJJ) = EY + NAKFF(JJJ) = NAK(KK) + NPFF(JJJ) = NP(KK) + NHFF(JJJ) = NH(KK) + GAMAFF(JJJ) = GAMA(KK) + CALL INTRPQF (PA, QA, MY, RA, JJJ, DNORM) IF (NTEST >= 100) WRITE (*, 301) NPFF(JJJ), NHFF(JJJ), EFF(JJJ)& - , DNORM - IF (NTEST > 1000) THEN - WRITE (*, *) 'PF QF RA' - DO KKK = 1, MFFF(JJJ) - WRITE (*, *) PFFF(KKK,JJJ), QFFF(KKK,JJJ), RA(KKK) - END DO - ENDIF - NWIN = NWIN + 1 - END DO - END DO - CALL DALLOC (PA, 'PA', 'LODRWFF') - CALL DALLOC (QA, 'QA', 'LODRWFF') - CALL DALLOC (RA, 'RA', 'LODRWFF') + , DNORM + IF (NTEST > 1000) THEN + WRITE (*, *) 'PF QF RA' + DO KKK = 1, MFFF(JJJ) + WRITE (*, *) PFFF(KKK,JJJ), QFFF(KKK,JJJ), RA(KKK) + END DO + ENDIF + NWIN = NWIN + 1 + END DO + END DO + CALL DALLOC (PA, 'PA', 'LODRWFF') + CALL DALLOC (QA, 'QA', 'LODRWFF') + CALL DALLOC (RA, 'RA', 'LODRWFF') - GO TO 3 - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + GO TO 3 + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWFF) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - IERR = 1 - GO TO 5 - ENDIF -! - WRITE (6, *) ' ... load complete;' -! - 5 CONTINUE - CLOSE(21) - IF (NTEST >= 100) THEN - WRITE (*, *) 'Sorted order should be the same as from kapdat' - DO J = 1, NWFF - WRITE (*, 301) NPFF(J), NHFF(J), EFF(J), DNORM - END DO - WRITE (*, *) - WRITE (*, *) '*****************' - WRITE (*, *) ' Leaving lodrwff' - WRITE (*, *) '*****************' - ENDIF - - RETURN -! - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN + IF (NWIN < NWFF) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + IERR = 1 + GO TO 5 + ENDIF +! + WRITE (6, *) ' ... load complete;' +! + 5 CONTINUE + CLOSE(21) + IF (NTEST >= 100) THEN + WRITE (*, *) 'Sorted order should be the same as from kapdat' + DO J = 1, NWFF + WRITE (*, 301) NPFF(J), NHFF(J), EFF(J), DNORM + END DO + WRITE (*, *) + WRITE (*, *) '*****************' + WRITE (*, *) ' Leaving lodrwff' + WRITE (*, *) '*****************' + ENDIF + + RETURN +! + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN ! END SUBROUTINE LODRWFF diff --git a/src/appl/rbiotransform90_mpi/lodrwffmpi_I.f90 b/src/appl/rbiotransform90_mpi/lodrwffmpi_I.f90 index 85d212a14..59e7478e0 100644 --- a/src/appl/rbiotransform90_mpi/lodrwffmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/lodrwffmpi_I.f90 @@ -1,11 +1,11 @@ - MODULE lodrwff_I + MODULE lodrwff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:28:07 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwff (NAME, NTESTG) - CHARACTER (LEN = 128), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwff (NAME, NTESTG) + CHARACTER (LEN = 128), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/lodrwfimpi.f90 b/src/appl/rbiotransform90_mpi/lodrwfimpi.f90 index 965364dea..0ac4e0e61 100644 --- a/src/appl/rbiotransform90_mpi/lodrwfimpi.f90 +++ b/src/appl/rbiotransform90_mpi/lodrwfimpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFI(NAME, NTESTG) + SUBROUTINE LODRWFI(NAME, NTESTG) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -10,13 +10,13 @@ SUBROUTINE LODRWFI(NAME, NTESTG) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE memory_man USE biorb_C @@ -29,49 +29,49 @@ SUBROUTINE LODRWFI(NAME, NTESTG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE intrpqi_I + USE intrpqi_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NTESTG + INTEGER, INTENT(IN) :: NTESTG CHARACTER, INTENT(IN) :: NAME*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: NAK, NP + INTEGER , DIMENSION(NNNW) :: NAK, NP INTEGER :: NTESTL, NTEST, J, K, I, NWIN, IOS, NPY, NAKY, MY, JJ, KK, JJJ& - , KKK, IERR - REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA - REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM + , KKK, IERR + REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA + REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER , DIMENSION(NNNW) :: NH*2 - CHARACTER :: G92RWF*6 + CHARACTER , DIMENSION(NNNW) :: NH*2 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the initial state ! ! - NTESTL = 0 - NTEST = MAX0(NTESTL,NTESTG) - NTEST = 0 - + NTESTL = 0 + NTEST = MAX0(NTESTL,NTESTG) + NTEST = 0 + ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' + WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21, FILE=NAME(1:J-1)//'.w', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Save NAK, NP and NH ! - NAK(:NWII) = NAKII(:NWII) - NP(:NWII) = NPII(:NWII) - NH(:NWII) = NHII(:NWII) + NAK(:NWII) = NAKII(:NWII) + NP(:NWII) = NPII(:NWII) + NH(:NWII) = NHII(:NWII) ! ! Allocate storage to orbital arrays ! @@ -79,113 +79,113 @@ SUBROUTINE LODRWFI(NAME, NTESTG) CALL ALLOC (QFII, NNNP,NWII, 'QFII', 'LODRWII') ! - CON = Z/C - CON = CON*CON + CON = Z/C + CON = CON*CON ! - DO J = 1, NWII - PFII(:NNNP,J) = 0.0D00 - QFII(:NNNP,J) = 0.0D00 + DO J = 1, NWII + PFII(:NNNP,J) = 0.0D00 + QFII(:NNNP,J) = 0.0D00 ! - K = ABS(NAK(J)) - IF (NPARM /= 0) CYCLE - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF + K = ABS(NAK(J)) + IF (NPARM /= 0) CYCLE + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NP(J), NH(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF ! - END DO + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (21, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(21) - ENDIF - - IF (NTEST >= 100) THEN - WRITE (*, *) '******************' - WRITE (*, *) ' Entering lodrwfi' - WRITE (*, *) '******************' - ENDIF - - 3 CONTINUE - READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY - IF (IOS == 0) THEN + NWIN = 0 + READ (21, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(21) + ENDIF + + IF (NTEST >= 100) THEN + WRITE (*, *) '******************' + WRITE (*, *) ' Entering lodrwfi' + WRITE (*, *) '******************' + ENDIF + + 3 CONTINUE + READ (21, IOSTAT=IOS) NPY, NAKY, EY, MY + IF (IOS == 0) THEN CALL ALLOC (PA, MY, 'PA', 'LODRWFII') CALL ALLOC (QA, MY, 'QA', 'LODRWFII') CALL ALLOC (RA, MY, 'RA', 'LODRWFII') - READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (21) (RA(I),I=1,MY) + READ (21) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (21) (RA(I),I=1,MY) ! ! Orbital order as defined in kapdata ! - JJ = 0 - DO K = 1, KAMAX - IF (K > 1) JJ = NSHLII(K-1) + JJ - DO J = 1, NSHLII(K) - KK = NSHLPII(K,J) - IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE - JJJ = JJ + J - PZII(JJJ) = PZY - EII(JJJ) = EY - NAKII(JJJ) = NAK(KK) - NPII(JJJ) = NP(KK) - NHII(JJJ) = NH(KK) - GAMAII(JJJ) = GAMA(KK) - CALL INTRPQI (PA, QA, MY, RA, JJJ, DNORM) + JJ = 0 + DO K = 1, KAMAX + IF (K > 1) JJ = NSHLII(K-1) + JJ + DO J = 1, NSHLII(K) + KK = NSHLPII(K,J) + IF (NPY/=NP(KK) .OR. NAKY/=NAK(KK)) CYCLE + JJJ = JJ + J + PZII(JJJ) = PZY + EII(JJJ) = EY + NAKII(JJJ) = NAK(KK) + NPII(JJJ) = NP(KK) + NHII(JJJ) = NH(KK) + GAMAII(JJJ) = GAMA(KK) + CALL INTRPQI (PA, QA, MY, RA, JJJ, DNORM) IF (NTEST >= 100) WRITE (*, 301) NPII(JJJ), NHII(JJJ), EII(JJJ)& - , DNORM - IF (NTEST > 1000) THEN - WRITE (*, *) 'PF QF RA' - DO KKK = 1, MFII(JJJ) - WRITE (*, *) PFII(KKK,JJJ), QFII(KKK,JJJ), RA(KKK) - END DO - ENDIF - NWIN = NWIN + 1 - END DO - END DO + , DNORM + IF (NTEST > 1000) THEN + WRITE (*, *) 'PF QF RA' + DO KKK = 1, MFII(JJJ) + WRITE (*, *) PFII(KKK,JJJ), QFII(KKK,JJJ), RA(KKK) + END DO + ENDIF + NWIN = NWIN + 1 + END DO + END DO CALL DALLOC (PA, 'PA', 'LODRWII') CALL DALLOC (QA, 'QA', 'LODRWII') CALL DALLOC (RA, 'RA', 'LODRWII') - GO TO 3 - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + GO TO 3 + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWII) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - IERR = 1 - GO TO 5 - ENDIF -! - WRITE (6, *) ' ... load complete;' -! - 5 CONTINUE - CLOSE(21) - IF (NTEST >= 100) THEN - WRITE (*, *) 'Sorted order should be the same as from kapdat' - DO J = 1, NWII - WRITE (*, 301) NPII(J), NHII(J), EII(J), DNORM - END DO - WRITE (*, *) - WRITE (*, *) '*****************' - WRITE (*, *) ' Leaving lodrwfi' - WRITE (*, *) '*****************' - ENDIF - - RETURN -! - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN + IF (NWIN < NWII) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + IERR = 1 + GO TO 5 + ENDIF +! + WRITE (6, *) ' ... load complete;' +! + 5 CONTINUE + CLOSE(21) + IF (NTEST >= 100) THEN + WRITE (*, *) 'Sorted order should be the same as from kapdat' + DO J = 1, NWII + WRITE (*, 301) NPII(J), NHII(J), EII(J), DNORM + END DO + WRITE (*, *) + WRITE (*, *) '*****************' + WRITE (*, *) ' Leaving lodrwfi' + WRITE (*, *) '*****************' + ENDIF + + RETURN +! + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN ! END SUBROUTINE LODRWFI diff --git a/src/appl/rbiotransform90_mpi/lodrwfimpi_I.f90 b/src/appl/rbiotransform90_mpi/lodrwfimpi_I.f90 index 59d67272b..63c1e1783 100644 --- a/src/appl/rbiotransform90_mpi/lodrwfimpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/lodrwfimpi_I.f90 @@ -1,11 +1,11 @@ - MODULE lodrwfi_I + MODULE lodrwfi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:29:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwfi (NAME, NTESTG) - CHARACTER (LEN = 128), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwfi (NAME, NTESTG) + CHARACTER (LEN = 128), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/lulu.f90 b/src/appl/rbiotransform90_mpi/lulu.f90 index 8ca38f565..88df711c5 100644 --- a/src/appl/rbiotransform90_mpi/lulu.f90 +++ b/src/appl/rbiotransform90_mpi/lulu.f90 @@ -4,7 +4,7 @@ ! L U L U ! ------------------------------------------------------------------ ! - SUBROUTINE LULU(A, L, U, NDIM) + SUBROUTINE LULU(A, L, U, NDIM) ! ! LU DECOMPOSITION OF MATRIX A ! @@ -38,55 +38,55 @@ SUBROUTINE LULU(A, L, U, NDIM) ! JEPPE OLSEN , OCTOBER 1988 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE inprod_I - USE prsym_I + USE inprod_I + USE prsym_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) - REAL(DOUBLE) :: L(*) - REAL(DOUBLE) :: U(*) + INTEGER :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) + REAL(DOUBLE) :: L(*) + REAL(DOUBLE) :: U(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: R, J, I, NTEST - REAL(DOUBLE) :: XFACI + INTEGER :: R, J, I, NTEST + REAL(DOUBLE) :: XFACI !----------------------------------------------- ! - DO R = 1, NDIM + DO R = 1, NDIM ! - DO J = R, NDIM - U(J*(J-1)/2+R) = A(R,J) - INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1) - END DO + DO J = R, NDIM + U(J*(J-1)/2+R) = A(R,J) - INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1) + END DO ! - XFACI = 1.0D0/U(R*(R+1)/2) - L(R*(R+1)/2) = 1.0D0 - DO I = R + 1, NDIM + XFACI = 1.0D0/U(R*(R+1)/2) + L(R*(R+1)/2) = 1.0D0 + DO I = R + 1, NDIM L(I*(I-1)/2+R) = (A(I,R)-INPROD(L(I*(I-1)/2+1),U(R*(R-1)/2+1),R-1))& - *XFACI - END DO + *XFACI + END DO ! - END DO + END DO ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' L MATRIX ' - CALL PRSYM (L, NDIM) - WRITE (6, *) ' U MATRIX ( TRANSPOSED ) ' - CALL PRSYM (U, NDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' L MATRIX ' + CALL PRSYM (L, NDIM) + WRITE (6, *) ' U MATRIX ( TRANSPOSED ) ' + CALL PRSYM (U, NDIM) + ENDIF ! - RETURN - END SUBROUTINE LULU + RETURN + END SUBROUTINE LULU diff --git a/src/appl/rbiotransform90_mpi/lulu_I.f90 b/src/appl/rbiotransform90_mpi/lulu_I.f90 index b5b84a34b..5369e8f2a 100644 --- a/src/appl/rbiotransform90_mpi/lulu_I.f90 +++ b/src/appl/rbiotransform90_mpi/lulu_I.f90 @@ -1,14 +1,14 @@ - MODULE lulu_I + MODULE lulu_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lulu (A, L, U, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: L - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: U - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lulu (A, L, U, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: L + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: U + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/matml4.f90 b/src/appl/rbiotransform90_mpi/matml4.f90 index dc029e48e..f2bc0fbeb 100644 --- a/src/appl/rbiotransform90_mpi/matml4.f90 +++ b/src/appl/rbiotransform90_mpi/matml4.f90 @@ -4,7 +4,7 @@ ! ------------------------------------------------------------------ ! SUBROUTINE MATML4(C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL, & - ITRNSP) + ITRNSP) ! ! MULTIPLY A AND B TO GIVE C ! @@ -17,89 +17,89 @@ SUBROUTINE MATML4(C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL, & !... JEPPE OLSEN, LAST REVISION JULY 24 1987 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE wrtmat_I - USE setvec_I + USE wrtmat_I + USE setvec_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCROW - INTEGER :: NCCOL - INTEGER :: NAROW - INTEGER :: NACOL - INTEGER :: NBROW - INTEGER :: NBCOL - INTEGER , INTENT(IN) :: ITRNSP - REAL(DOUBLE) :: C(NCROW,NCCOL) - REAL(DOUBLE) :: A(NAROW,NACOL) - REAL(DOUBLE) :: B(NBROW,NBCOL) + INTEGER :: NCROW + INTEGER :: NCCOL + INTEGER :: NAROW + INTEGER :: NACOL + INTEGER :: NBROW + INTEGER :: NBCOL + INTEGER , INTENT(IN) :: ITRNSP + REAL(DOUBLE) :: C(NCROW,NCCOL) + REAL(DOUBLE) :: A(NAROW,NACOL) + REAL(DOUBLE) :: B(NBROW,NBCOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTEST, J, K, I - REAL(DOUBLE) :: BKJ, BJK + INTEGER :: NTEST, J, K, I + REAL(DOUBLE) :: BKJ, BJK !----------------------------------------------- ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) - WRITE (6, *) ' A AND B MATRIX FROM MATML4 ' - WRITE (6, *) - CALL WRTMAT (A, NAROW, NACOL, NAROW, NACOL) - CALL WRTMAT (B, NBROW, NBCOL, NBROW, NBCOL) - WRITE (6, *) ' NCROW NCCOL NAROW NACOL NBROW NBCOL ' - WRITE (6, '(6I6)') NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL - ENDIF -! - CALL SETVEC (C, 0.0D0, NCROW*NCCOL) -! - IF (ITRNSP == 0) THEN - DO J = 1, NCCOL - DO K = 1, NBROW - BKJ = B(K,J) - C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BKJ - END DO - END DO - ENDIF -! -! - IF (ITRNSP == 1) THEN + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) + WRITE (6, *) ' A AND B MATRIX FROM MATML4 ' + WRITE (6, *) + CALL WRTMAT (A, NAROW, NACOL, NAROW, NACOL) + CALL WRTMAT (B, NBROW, NBCOL, NBROW, NBCOL) + WRITE (6, *) ' NCROW NCCOL NAROW NACOL NBROW NBCOL ' + WRITE (6, '(6I6)') NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL + ENDIF +! + CALL SETVEC (C, 0.0D0, NCROW*NCCOL) +! + IF (ITRNSP == 0) THEN + DO J = 1, NCCOL + DO K = 1, NBROW + BKJ = B(K,J) + C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BKJ + END DO + END DO + ENDIF +! +! + IF (ITRNSP == 1) THEN !... C = A(T) * B - DO J = 1, NCCOL - DO K = 1, NBROW - BKJ = B(K,J) - C(:NCROW,J) = C(:NCROW,J) + A(K,:NCROW)*BKJ - END DO - END DO - ENDIF -! - IF (ITRNSP == 2) THEN + DO J = 1, NCCOL + DO K = 1, NBROW + BKJ = B(K,J) + C(:NCROW,J) = C(:NCROW,J) + A(K,:NCROW)*BKJ + END DO + END DO + ENDIF +! + IF (ITRNSP == 2) THEN !... C = A*B(T) - DO J = 1, NCCOL - DO K = 1, NBCOL - BJK = B(J,K) - C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BJK - END DO - END DO - ENDIF -! -! - IF (NTEST /= 0) THEN - WRITE (6, *) - WRITE (6, *) ' C MATRIX FROM MATML4 ' - WRITE (6, *) - CALL WRTMAT (C, NCROW, NCCOL, NCROW, NCCOL) - ENDIF -! - RETURN - END SUBROUTINE MATML4 + DO J = 1, NCCOL + DO K = 1, NBCOL + BJK = B(J,K) + C(:NCROW,J) = C(:NCROW,J) + A(:NCROW,K)*BJK + END DO + END DO + ENDIF +! +! + IF (NTEST /= 0) THEN + WRITE (6, *) + WRITE (6, *) ' C MATRIX FROM MATML4 ' + WRITE (6, *) + CALL WRTMAT (C, NCROW, NCCOL, NCROW, NCCOL) + ENDIF +! + RETURN + END SUBROUTINE MATML4 diff --git a/src/appl/rbiotransform90_mpi/matml4_I.f90 b/src/appl/rbiotransform90_mpi/matml4_I.f90 index acdc552d2..766630d3a 100644 --- a/src/appl/rbiotransform90_mpi/matml4_I.f90 +++ b/src/appl/rbiotransform90_mpi/matml4_I.f90 @@ -1,21 +1,21 @@ - MODULE matml4_I + MODULE matml4_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE matml4 (C, A, B, NCROW, NCCOL, NAROW, NACOL, NBROW, NBCOL& - , ITRNSP) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCROW,NCCOL), INTENT(INOUT) :: C - REAL(DOUBLE), DIMENSION(NAROW,NACOL), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(NBROW,NBCOL), INTENT(IN) :: B - INTEGER, INTENT(IN) :: NCROW - INTEGER, INTENT(IN) :: NCCOL - INTEGER, INTENT(IN) :: NAROW - INTEGER, INTENT(IN) :: NACOL - INTEGER, INTENT(IN) :: NBROW - INTEGER, INTENT(IN) :: NBCOL - INTEGER, INTENT(IN) :: ITRNSP - END SUBROUTINE - END INTERFACE - END MODULE + , ITRNSP) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCROW,NCCOL), INTENT(INOUT) :: C + REAL(DOUBLE), DIMENSION(NAROW,NACOL), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(NBROW,NBCOL), INTENT(IN) :: B + INTEGER, INTENT(IN) :: NCROW + INTEGER, INTENT(IN) :: NCCOL + INTEGER, INTENT(IN) :: NAROW + INTEGER, INTENT(IN) :: NACOL + INTEGER, INTENT(IN) :: NBROW + INTEGER, INTENT(IN) :: NBCOL + INTEGER, INTENT(IN) :: ITRNSP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/mcpinmpi.f90 b/src/appl/rbiotransform90_mpi/mcpinmpi.f90 index 80cf53bb9..e197bfffe 100644 --- a/src/appl/rbiotransform90_mpi/mcpinmpi.f90 +++ b/src/appl/rbiotransform90_mpi/mcpinmpi.f90 @@ -20,7 +20,7 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) ! Bug corrected 2005-10-18 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -68,11 +68,11 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) INTEGER, PARAMETER :: KEY = KEYORB, KEYSQ = KEY*KEY, nvmax=100 REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 INTEGER, PARAMETER :: NF = 200 - + LOGICAL :: F0INT,LINCR,RESTRT,COMP,AVAIL CHARACTER(LEN=20) :: CNUM CHARACTER(LEN=2) :: CK -! +! REAL(DOUBLE), DIMENSION(NNNW) :: tshell REAL(DOUBLE), DIMENSION(NVMAX) ::SC INTEGER, DIMENSION(NNNW) :: nakinv @@ -87,7 +87,7 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) NTESTL = 00 NTEST = MAX(NTESTG,NTESTL) NTEST = 00 - + ! ! Set up data for the initial and final state case respectively ! @@ -96,55 +96,55 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) NSHL(I) = NSHLII(I) NINL(I) = NINII(I) ENDDO - + DO I = 1,NNNW NAKINV(I) = NAKINVII(I) ENDDO - + DO J = 1,NLMAX DO I = 1,NLMAX NSHLP(I,J) = NSHLPII(I,J) ENDDO ENDDO - + DO J = 1,NNNW DO I = 1,NLMAX NSHLPP(I,J) = NSHLPPII(I,J) ENDDO ENDDO - + DO I = 1,20*NLMAX*NLMAX CIROT(I) = CICI(I) ENDDO - + ELSEIF (IK.EQ.2) THEN - + DO I = 1,NLMAX NSHL(I) = NSHLFF(I) NINL(I) = NINFF(I) ENDDO - + DO I = 1,NNNW NAKINV(I) = NAKINVFF(I) ENDDO - + DO J = 1,NLMAX DO I = 1,NLMAX NSHLP(I,J) = NSHLPFF(I,J) ENDDO ENDDO - + DO J = 1,NNNW DO I = 1,NLMAX NSHLPP(I,J) = NSHLPPFF(I,J) ENDDO ENDDO - + DO I = 1,20*NLMAX*NLMAX CIROT(I) = CFCI(I) ENDDO ENDIF - + REWIND (NF) DO 1000 IBLK = 1, NBLOCK ! @@ -162,7 +162,7 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) ! READ(NF) NCFD,NWD,KAMAXD DO L = 1,KAMAX - + !************ ! !. Offset for given L in shell matrices @@ -173,9 +173,9 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) IIOFF = IIOFF + NSHL(L-1)** 2 END IF ! Corrected PER J - + !************** - + READ(NF) NINTG,NCOEFF IF(NCOEFF*NINTG.EQ.0) CYCLE ! @@ -188,7 +188,7 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) CALL ALLOC (INTGRL,NINTG, 'INTGRL', 'MCPIN') CALL ALLOC (CNN,NCOEFF, 'CNN', 'MCPIN') CALL ALLOC (INTPTR,NINTG, 'INTPTR', 'MCPIN') - + DO I = 1,NINTG READ(NF) INTGRL(I),INTPTR(I) ENDDO @@ -219,15 +219,15 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) CALL DALLOC (INTGRL, 'INTGRL', 'MCPIN') CALL DALLOC (CNN, 'CNN', 'MCPIN') CALL DALLOC (INTPTR, 'INTPRT', 'MCPIN') - + ENDDO - + CALL dalloc (scr, 'SCR', 'MCPIN') CALL dalloc (ciout, 'CIOUT', 'MCPIN') ! ! Write the rotated CI vectors on file ! - IF(myid .eq. 0) THEN + IF(myid .eq. 0) THEN IF(IBLK.EQ.1) THEN J = INDEX(NAME,' ') IF (INPCI.EQ.0) THEN @@ -246,7 +246,7 @@ SUBROUTINE MCPIN (NAME,startdir,IK,NTESTG,INPCI) WRITE(31) EAV,(EVAL(I),I = 1,NVEC) WRITE(31) ((EVEC(I+(J-1)*NCF),I = 1,NCF),J = 1,NVEC) endif !myid=0 - + CALL DALLOC (EVAL, 'EVAL', 'MCPIN') CALL DALLOC (EVEC, 'EVEC', 'MCPIN') CALL DALLOC (IVEC, 'IVEC', 'MCPIN') diff --git a/src/appl/rbiotransform90_mpi/mcpinmpi_I.f90 b/src/appl/rbiotransform90_mpi/mcpinmpi_I.f90 index 55845e2f6..b833bf6c9 100644 --- a/src/appl/rbiotransform90_mpi/mcpinmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/mcpinmpi_I.f90 @@ -1,12 +1,12 @@ - MODULE mcpin_I + MODULE mcpin_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mcpin (NAME, IK, NTESTG, INPCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mcpin (NAME, IK, NTESTG, INPCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/mcpoutmpi_gg.f90 b/src/appl/rbiotransform90_mpi/mcpoutmpi_gg.f90 index 57e848afa..45a4ff544 100644 --- a/src/appl/rbiotransform90_mpi/mcpoutmpi_gg.f90 +++ b/src/appl/rbiotransform90_mpi/mcpoutmpi_gg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCPOUT(NAME, startdir, IK, NTESTG, INPCI) + SUBROUTINE MCPOUT(NAME, startdir, IK, NTESTG, INPCI) ! * ! This routine controls the computation and storage of the values * ! and all indices of the angular coefficients * @@ -19,23 +19,23 @@ SUBROUTINE MCPOUT(NAME, startdir, IK, NTESTG, INPCI) ! Written by Per Jonsson Last revision: JUne 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, KEYORB USE memory_man ! USE def_C -! USE EIGV_C - USE FOPARM_C - USE MCP_C - USE PRNT_C - USE SYMA_C - USE STAT_C - USE BLK_C +! USE EIGV_C + USE FOPARM_C + USE MCP_C + USE PRNT_C + USE SYMA_C + USE STAT_C + USE BLK_C USE orb_C, ONLY: ncf, nw,nak, iqa USE jqjc_C USE orbord_C @@ -46,200 +46,200 @@ SUBROUTINE MCPOUT(NAME, startdir, IK, NTESTG, INPCI) ! I n t e r f a c e B l o c k s !----------------------------------------------- USE onescalar_I - USE cord_I - USE itjpo_I - USE angdata_I - USE qqsort_I + USE cord_I + USE itjpo_I + USE angdata_I + USE qqsort_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - CHARACTER :: NAME*24 - CHARACTER :: startdir*128 + INTEGER :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + CHARACTER :: NAME*24 + CHARACTER :: startdir*128 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NF = 200 - INTEGER, PARAMETER :: NVMAX = 100 + INTEGER, PARAMETER :: NF = 200 + INTEGER, PARAMETER :: NVMAX = 100 INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: KEYSQ = KEY*KEY - REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 + INTEGER, PARAMETER :: KEYSQ = KEY*KEY + REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NLMAX) :: LLISTT - INTEGER, DIMENSION(NNNW) :: NAKINV - INTEGER, DIMENSION(NLMAX) :: NSHL, NINL + INTEGER, DIMENSION(NLMAX) :: LLISTT + INTEGER, DIMENSION(NNNW) :: NAKINV + INTEGER, DIMENSION(NLMAX) :: NSHL, NINL INTEGER :: I, NTESTL, NTEST, KA, IOPAR, J, NCF0, IBLK, K, & - JA, JB, IBB, IA, IB, LAB, JAN, JBN, L - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL - REAL(DOUBLE), DIMENSION(NVMAX) :: SC - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CIROT - REAL(DOUBLE), DIMENSION(10000) :: EVSC - LOGICAL :: F0INT, LINCR, RESTRT, COMP, AVAIL - CHARACTER :: CNUM*20, CK*2 + JA, JB, IBB, IA, IB, LAB, JAN, JBN, L + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + REAL(DOUBLE), DIMENSION(NVMAX) :: SC + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CIROT + REAL(DOUBLE), DIMENSION(10000) :: EVSC + LOGICAL :: F0INT, LINCR, RESTRT, COMP, AVAIL + CHARACTER :: CNUM*20, CK*2 !----------------------------------------------- ! ! Locals ! POINTER (pscr, scr(1)) ! POINTER (pciout, ciout(1)) ! - - WRITE (6, *) 'NBLOCK,(NCFBLK(i),i=1,NBLOCK)' - WRITE (6, *) NBLOCK, (NCFBLK(I),I=1,NBLOCK) - - NTESTL = 0 - NTEST = MAX(NTESTG,NTESTL) - NTEST = 0 + + WRITE (6, *) 'NBLOCK,(NCFBLK(i),i=1,NBLOCK)' + WRITE (6, *) NBLOCK, (NCFBLK(I),I=1,NBLOCK) + + NTESTL = 0 + NTEST = MAX(NTESTG,NTESTL) + NTEST = 0 ! ! Set the rank (zero) and parity (even) for the one-particle ! coefficients ! - KA = 0 - IOPAR = 1 + KA = 0 + IOPAR = 1 ! ! Check if angular data is available. If available read this data. ! If not available calculate the data ! - CALL ANGDATA (NAME, AVAIL, KAMAX) - WRITE (6, *) 'AVAIL=', AVAIL - IF (AVAIL) RETURN - - IF (IK == 1) THEN - NAKINV(:NNNW) = NAKINVII(:NNNW) - ELSE - NAKINV(:NNNW) = NAKINVFF(:NNNW) - ENDIF - - - - WRITE (6, *) ' open sorted ang. file .TB(NF)', NF - J = INDEX(NAME,' ') + CALL ANGDATA (NAME, AVAIL, KAMAX) + WRITE (6, *) 'AVAIL=', AVAIL + IF (AVAIL) RETURN + + IF (IK == 1) THEN + NAKINV(:NNNW) = NAKINVII(:NNNW) + ELSE + NAKINV(:NNNW) = NAKINVFF(:NNNW) + ENDIF + + + + WRITE (6, *) ' open sorted ang. file .TB(NF)', NF + J = INDEX(NAME,' ') OPEN(UNIT=NF, FILE=NAME(1:J-1)//'.TB', STATUS='UNKNOWN', FORM=& - 'UNFORMATTED', POSITION='asis') - - NCF0 = 1 - DO IBLK = 1, NBLOCK + 'UNFORMATTED', POSITION='asis') + + NCF0 = 1 + DO IBLK = 1, NBLOCK ! ! Open scratchfiles to dump the T coefficients for each kappa ! - DO K = 1, KAMAX + DO K = 1, KAMAX OPEN(UNIT=80 + K, STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - END DO + 'asis') + END DO ! ! Initialize the counters for the total number of T coefficients ! - LLISTT(:NLMAX) = 0 + LLISTT(:NLMAX) = 0 ! ! JA and JB respectively refer to the initial and final states ! in the list of NCF configurations ! DO JA = myid+NCF0,NCFBLK(IBLK),nprocs - IF (MOD(JA,100)==0 .AND. IK==1) THEN - WRITE (*, *) ' JA1 =', JA, JA - NCF0 + 1 - ELSE IF (MOD(JA,100)==0 .AND. IK==2) THEN - WRITE (*, *) ' JA2 =', JA, JA - NCF0 + 1 - ENDIF + IF (MOD(JA,100)==0 .AND. IK==1) THEN + WRITE (*, *) ' JA1 =', JA, JA - NCF0 + 1 + ELSE IF (MOD(JA,100)==0 .AND. IK==2) THEN + WRITE (*, *) ' JA2 =', JA, JA - NCF0 + 1 + ENDIF ! - DO JB = NCF0, NCFBLK(IBLK) + DO JB = NCF0, NCFBLK(IBLK) ! ! Call the MCT package to compute T coefficients ! - IF (NTRANS == 1) THEN - COMP = .FALSE. - IF (IK == 1) THEN - DO IBB = 1, JQJ1 - IF (ITJPO(JA) /= ITJQJ1(IBB)) CYCLE - COMP = .TRUE. - END DO - ELSE - DO IBB = 1, JQJ2 - IF (ITJPO(JA) /= ITJQJ2(IBB)) CYCLE - COMP = .TRUE. - END DO - ENDIF - ELSE - COMP = .TRUE. - ENDIF - - - IF (.NOT.COMP) CYCLE + IF (NTRANS == 1) THEN + COMP = .FALSE. + IF (IK == 1) THEN + DO IBB = 1, JQJ1 + IF (ITJPO(JA) /= ITJQJ1(IBB)) CYCLE + COMP = .TRUE. + END DO + ELSE + DO IBB = 1, JQJ2 + IF (ITJPO(JA) /= ITJQJ2(IBB)) CYCLE + COMP = .TRUE. + END DO + ENDIF + ELSE + COMP = .TRUE. + ENDIF + + + IF (.NOT.COMP) CYCLE ! write(*,*) JA,JB -!GG CALL TNSRJJ (KA, IOPAR, JA, JB, IA, IB, TSHELL) +!GG CALL TNSRJJ (KA, IOPAR, JA, JB, IA, IB, TSHELL) CALL ONESCALAR(JA,JB,IA,IB,TSHELL) - IF (IA == 0) CYCLE - IF (IA == IB) THEN - DO IA = 1, NW + IF (IA == 0) CYCLE + IF (IA == IB) THEN + DO IA = 1, NW ! ! If T coefficient is greater than zero and the kappa quantum numbers ! of the two orbitals are the same dump to file ! In a later version use a buffer with a reasonable record length ! - IF (DABS(TSHELL(IA)) <= CUTOFF) CYCLE - LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 - LAB = IA*KEY + IA + IF (DABS(TSHELL(IA)) <= CUTOFF) CYCLE + LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 + LAB = IA*KEY + IA WRITE (80 + NAKINV(IA)) JA - NCF0 + 1, JB - NCF0 + 1, LAB& - , TSHELL(IA) - END DO - ELSE - IF (DABS(TSHELL(1))>CUTOFF .AND. NAK(IA)==NAK(IB)) THEN - LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 - IF (NORDII==0 .AND. NORDFF==0) THEN + , TSHELL(IA) + END DO + ELSE + IF (DABS(TSHELL(1))>CUTOFF .AND. NAK(IA)==NAK(IB)) THEN + LLISTT(NAKINV(IA)) = LLISTT(NAKINV(IA)) + 1 + IF (NORDII==0 .AND. NORDFF==0) THEN ! ! Experssion for normal orbital ordering ! - LAB = IA*KEY + IB - JAN = JA - NCF0 + 1 - JBN = JB - NCF0 + 1 - ELSE IF (NORDII==1 .AND. NORDFF==1) THEN + LAB = IA*KEY + IB + JAN = JA - NCF0 + 1 + JBN = JB - NCF0 + 1 + ELSE IF (NORDII==1 .AND. NORDFF==1) THEN ! ! Experssion for reversed orbital ordering ! - LAB = IB*KEY + IA - JAN = JB - NCF0 + 1 - JBN = JA - NCF0 + 1 - ELSE + LAB = IB*KEY + IA + JAN = JB - NCF0 + 1 + JBN = JA - NCF0 + 1 + ELSE WRITE (*, *) 'SOMETHING WRONG' STOP - ENDIF - WRITE (80 + NAKINV(IA)) JAN, JBN, LAB, TSHELL(1) - ENDIF - ENDIF + ENDIF + WRITE (80 + NAKINV(IA)) JAN, JBN, LAB, TSHELL(1) + ENDIF + ENDIF ! - END DO - END DO - - + END DO + END DO + + ! ! sort the MCP data into inegral based lists. ! - DO L = 1, KAMAX - IF (LLISTT(L) > 0) THEN - CALL QQSORT (L, LLISTT(L), IK, NAME, KAMAX) - ELSE - IF (L == 1) WRITE (NF) NCF, NW, KAMAX - WRITE (NF) LLISTT(L), LLISTT(L) - ENDIF - END DO + DO L = 1, KAMAX + IF (LLISTT(L) > 0) THEN + CALL QQSORT (L, LLISTT(L), IK, NAME, KAMAX) + ELSE + IF (L == 1) WRITE (NF) NCF, NW, KAMAX + WRITE (NF) LLISTT(L), LLISTT(L) + ENDIF + END DO ! ! Close the angular files ! - DO L = 1, KAMAX - CLOSE(L + 80, STATUS='DELETE') - END DO + DO L = 1, KAMAX + CLOSE(L + 80, STATUS='DELETE') + END DO ! - NCF0 = NCFBLK(IBLK) + 1 - END DO + NCF0 = NCFBLK(IBLK) + 1 + END DO ! ! Deallocate storage that is no longer required. This was ! allocated in lodcsl. ! - CALL DALLOC (IQA, 'IQA', 'MCPOUT') - CALL DALLOC (JQSA, 'JQSA', 'MCPOUT') - CALL DALLOC (JCUPA, 'JCUPA', 'MCPOUT') - RETURN - END SUBROUTINE MCPOUT + CALL DALLOC (IQA, 'IQA', 'MCPOUT') + CALL DALLOC (JQSA, 'JQSA', 'MCPOUT') + CALL DALLOC (JCUPA, 'JCUPA', 'MCPOUT') + RETURN + END SUBROUTINE MCPOUT diff --git a/src/appl/rbiotransform90_mpi/mcpoutmpi_gg_I.f90 b/src/appl/rbiotransform90_mpi/mcpoutmpi_gg_I.f90 index 64072ce1e..dfd7bebe0 100644 --- a/src/appl/rbiotransform90_mpi/mcpoutmpi_gg_I.f90 +++ b/src/appl/rbiotransform90_mpi/mcpoutmpi_gg_I.f90 @@ -1,14 +1,14 @@ - MODULE mcpout_I + MODULE mcpout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mcpout (NAME, startdir,IK, NTESTG, INPCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME + SUBROUTINE mcpout (NAME, startdir,IK, NTESTG, INPCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME CHARACTER (LEN = 128) :: startdir - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: NTESTG - INTEGER :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: NTESTG + INTEGER :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/orbord.f90 b/src/appl/rbiotransform90_mpi/orbord.f90 index dbf45c886..4377f6a16 100644 --- a/src/appl/rbiotransform90_mpi/orbord.f90 +++ b/src/appl/rbiotransform90_mpi/orbord.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ORBORD(N) + SUBROUTINE ORBORD(N) ! * ! THIS ROUTINE DOES NOTHING! @@ -11,24 +11,24 @@ SUBROUTINE ORBORD(N) ! Written by Per Jonsson Last revision: Feb 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE orb_C USE biorb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N + INTEGER :: N !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- !----------------------------------------------- - - RETURN - END SUBROUTINE ORBORD + + RETURN + END SUBROUTINE ORBORD diff --git a/src/appl/rbiotransform90_mpi/orbord_I.f90 b/src/appl/rbiotransform90_mpi/orbord_I.f90 index 4fab195b6..adea5a3fa 100644 --- a/src/appl/rbiotransform90_mpi/orbord_I.f90 +++ b/src/appl/rbiotransform90_mpi/orbord_I.f90 @@ -1,10 +1,10 @@ - MODULE orbord_I + MODULE orbord_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orbord (N) - INTEGER :: N - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE orbord (N) + INTEGER :: N + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/pamtmt.f90 b/src/appl/rbiotransform90_mpi/pamtmt.f90 index 041d8083b..e934379f3 100644 --- a/src/appl/rbiotransform90_mpi/pamtmt.f90 +++ b/src/appl/rbiotransform90_mpi/pamtmt.f90 @@ -3,7 +3,7 @@ ! P A M T M T ! ------------------------------------------------------------------ ! - SUBROUTINE PAMTMT(X, T, WORK, NORB) + SUBROUTINE PAMTMT(X, T, WORK, NORB) ! ! GENERATE PER AKE'S T MATRIX FROM A ! ORBITAL ROTATION MATRIX X @@ -23,72 +23,72 @@ SUBROUTINE PAMTMT(X, T, WORK, NORB) ! JEPPE OLSEN OCTOBER 1988 ! !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lulu_I - USE setvec_I - USE wrtmat_I - USE invmat_I + USE lulu_I + USE setvec_I + USE wrtmat_I + USE invmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NORB - REAL(DOUBLE) :: X(NORB,NORB) - REAL(DOUBLE) :: T(NORB,NORB) - REAL(DOUBLE) :: WORK(*) + INTEGER :: NORB + REAL(DOUBLE) :: X(NORB,NORB) + REAL(DOUBLE) :: T(NORB,NORB) + REAL(DOUBLE) :: WORK(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NTEST, KLFREE, KLL, KLU, I, J + INTEGER :: NTEST, KLFREE, KLL, KLU, I, J !----------------------------------------------- ! DIMENSION OF WORK : NORB ** 2 + NORB*(NORB+1) / 2 ! - NTEST = 0 + NTEST = 0 !. Allocate local memory - KLFREE = 1 + KLFREE = 1 ! KLL = KFLREE - KLL = KLFREE - KLFREE = KLL + NORB*(NORB + 1)/2 - KLU = KLFREE - KLFREE = KLU + NORB**2 + KLL = KLFREE + KLFREE = KLL + NORB*(NORB + 1)/2 + KLU = KLFREE + KLFREE = KLU + NORB**2 !.LU factorize X - CALL LULU (X, WORK(KLL), WORK(KLU), NORB) + CALL LULU (X, WORK(KLL), WORK(KLU), NORB) !.Expand U to full matrix - CALL SETVEC (T, 0.0D0, NORB**2) - DO I = 1, NORB - DO J = I, NORB - T(I,J) = WORK(KLU-1+J*(J-1)/2+I) - END DO - END DO - IF (NTEST >= 10) THEN - WRITE (6, *) ' MATRIX TO BE INVERTED ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + CALL SETVEC (T, 0.0D0, NORB**2) + DO I = 1, NORB + DO J = I, NORB + T(I,J) = WORK(KLU-1+J*(J-1)/2+I) + END DO + END DO + IF (NTEST >= 10) THEN + WRITE (6, *) ' MATRIX TO BE INVERTED ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF !.Invert U - CALL INVMAT (T, WORK(KLU), NORB, NORB) - IF (NTEST >= 10) THEN - WRITE (6, *) ' INVERTED MATRIX ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + CALL INVMAT (T, WORK(KLU), NORB, NORB) + IF (NTEST >= 10) THEN + WRITE (6, *) ' INVERTED MATRIX ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF !.Subtract L - DO I = 1, NORB - T(I,:I-1) = -WORK(KLL+I*(I-1)/2:I-2+KLL+I*(I-1)/2) - END DO + DO I = 1, NORB + T(I,:I-1) = -WORK(KLL+I*(I-1)/2:I-2+KLL+I*(I-1)/2) + END DO ! - IF (NTEST /= 0) THEN - WRITE (6, *) ' INPUT X MATRIX ' - CALL WRTMAT (X, NORB, NORB, NORB, NORB) - WRITE (6, *) ' T MATRIX ' - CALL WRTMAT (T, NORB, NORB, NORB, NORB) - ENDIF + IF (NTEST /= 0) THEN + WRITE (6, *) ' INPUT X MATRIX ' + CALL WRTMAT (X, NORB, NORB, NORB, NORB) + WRITE (6, *) ' T MATRIX ' + CALL WRTMAT (T, NORB, NORB, NORB, NORB) + ENDIF ! - RETURN - END SUBROUTINE PAMTMT + RETURN + END SUBROUTINE PAMTMT diff --git a/src/appl/rbiotransform90_mpi/pamtmt_I.f90 b/src/appl/rbiotransform90_mpi/pamtmt_I.f90 index acde6d6c2..dea18e68d 100644 --- a/src/appl/rbiotransform90_mpi/pamtmt_I.f90 +++ b/src/appl/rbiotransform90_mpi/pamtmt_I.f90 @@ -1,14 +1,14 @@ - MODULE pamtmt_I + MODULE pamtmt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE pamtmt (X, T, WORK, NORB) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NORB,NORB) :: X - REAL(DOUBLE), DIMENSION(NORB,NORB), INTENT(OUT) :: T - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: WORK - INTEGER, INTENT(IN) :: NORB - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE pamtmt (X, T, WORK, NORB) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NORB,NORB) :: X + REAL(DOUBLE), DIMENSION(NORB,NORB), INTENT(OUT) :: T + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: WORK + INTEGER, INTENT(IN) :: NORB + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/prsym.f90 b/src/appl/rbiotransform90_mpi/prsym.f90 index ed5801885..6c63a33b6 100644 --- a/src/appl/rbiotransform90_mpi/prsym.f90 +++ b/src/appl/rbiotransform90_mpi/prsym.f90 @@ -2,36 +2,36 @@ ! P R S Y M ! ------------------------------------------------------------------ ! - SUBROUTINE PRSYM(A, MATDIM) + SUBROUTINE PRSYM(A, MATDIM) ! PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. ! THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MATDIM - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A + INTEGER, INTENT(IN) :: MATDIM + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: A !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: JSTART, JSTOP, I, J -!----------------------------------------------- - JSTART = 1 - JSTOP = 0 - DO I = 1, MATDIM - JSTART = JSTART + I - 1 - JSTOP = JSTOP + I - WRITE (6, 1010) I, (A(J),J=JSTART,JSTOP) - END DO - RETURN - 1010 FORMAT('0',2X,I3,5(1X,E14.7),/,(' ',5X,5(1X,E14.7))) - RETURN - END SUBROUTINE PRSYM + INTEGER :: JSTART, JSTOP, I, J +!----------------------------------------------- + JSTART = 1 + JSTOP = 0 + DO I = 1, MATDIM + JSTART = JSTART + I - 1 + JSTOP = JSTOP + I + WRITE (6, 1010) I, (A(J),J=JSTART,JSTOP) + END DO + RETURN + 1010 FORMAT('0',2X,I3,5(1X,E14.7),/,(' ',5X,5(1X,E14.7))) + RETURN + END SUBROUTINE PRSYM diff --git a/src/appl/rbiotransform90_mpi/prsym_I.f90 b/src/appl/rbiotransform90_mpi/prsym_I.f90 index 2dd2ac146..29e84b8a7 100644 --- a/src/appl/rbiotransform90_mpi/prsym_I.f90 +++ b/src/appl/rbiotransform90_mpi/prsym_I.f90 @@ -1,13 +1,13 @@ - MODULE prsym_I + MODULE prsym_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prsym (A, MATDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(1), INTENT(IN) :: A - INTEGER, INTENT(IN) :: MATDIM + SUBROUTINE prsym (A, MATDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(1), INTENT(IN) :: A + INTEGER, INTENT(IN) :: MATDIM !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/qqsortmpi.f90 b/src/appl/rbiotransform90_mpi/qqsortmpi.f90 index 45a1e7eb7..1416bde51 100644 --- a/src/appl/rbiotransform90_mpi/qqsortmpi.f90 +++ b/src/appl/rbiotransform90_mpi/qqsortmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) + SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! * ! The list of unique integrals (j,i) is formed in the order of * ! increasing symmetry, i.e. with j .le. i. * @@ -21,13 +21,13 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE orb_C @@ -41,128 +41,128 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NUMBER - INTEGER :: KSTART - INTEGER, INTENT(IN) :: KAMAX - CHARACTER :: NAME*24 + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NUMBER + INTEGER :: KSTART + INTEGER, INTENT(IN) :: KAMAX + CHARACTER :: NAME*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: NF = 200 + INTEGER, PARAMETER :: NF = 200 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, L, IR, JA, JB, INT, J, INTT - REAL(DOUBLE) :: CN + REAL(DOUBLE) :: CN !----------------------------------------------- ! - REWIND (NFILE + 80) - - NCOEFF = NUMBER + REWIND (NFILE + 80) + + NCOEFF = NUMBER ! ! Sort the list ! ! Allocate storage for all required arrays these arrays are then deallocated ! in mcp ! - CALL ALLOC (JANN, NCOEFF, 'JANN', 'QQSORT') - CALL ALLOC (JBNN, NCOEFF, 'JBNN', 'QQSORT') - CALL ALLOC (INTGRL, NCOEFF, 'INTGRL', 'QQSORT') - CALL ALLOC (CNN, NCOEFF, 'CNN', 'QQSORT') - CALL ALLOC (INTPTR, NCOEFF, 'INTPTR', 'QQSORT') + CALL ALLOC (JANN, NCOEFF, 'JANN', 'QQSORT') + CALL ALLOC (JBNN, NCOEFF, 'JBNN', 'QQSORT') + CALL ALLOC (INTGRL, NCOEFF, 'INTGRL', 'QQSORT') + CALL ALLOC (CNN, NCOEFF, 'CNN', 'QQSORT') + CALL ALLOC (INTPTR, NCOEFF, 'INTPTR', 'QQSORT') ! ! Read arrays into memory from NFILE ! - DO I = 1, NCOEFF - READ (NFILE + 80) JANN(I), JBNN(I), INTGRL(I), CNN(I) - END DO + DO I = 1, NCOEFF + READ (NFILE + 80) JANN(I), JBNN(I), INTGRL(I), CNN(I) + END DO ! ! Sort INTGRL into ascending order using the heapsort algorithm; ! (Numerical recepies page 231.) move the associated members of ! of JANN and JBNN in the same ! manner; ! - IF (NCOEFF > 1) THEN -! - L = NCOEFF/2 + 1 - IR = NCOEFF - 2 CONTINUE - IF (L > 1) THEN - L = L - 1 - JA = JANN(L) - JB = JBNN(L) - INT = INTGRL(L) - CN = CNN(L) - ELSE - JA = JANN(IR) - JB = JBNN(IR) - INT = INTGRL(IR) - CN = CNN(IR) - JANN(IR) = JANN(1) - JBNN(IR) = JBNN(1) - INTGRL(IR) = INTGRL(1) - CNN(IR) = CNN(1) - IR = IR - 1 - IF (IR == 1) THEN - JANN(1) = JA - JBNN(1) = JB - INTGRL(1) = INT - CNN(1) = CN - GO TO 4 - ENDIF - ENDIF - I = L - J = L + L - 3 CONTINUE - IF (J <= IR) THEN - IF (J < IR) THEN - IF (INTGRL(J) < INTGRL(J+1)) J = J + 1 - ENDIF - IF (INT < INTGRL(J)) THEN - JANN(I) = JANN(J) - JBNN(I) = JBNN(J) - INTGRL(I) = INTGRL(J) - CNN(I) = CNN(J) - I = J - J = J + J - ELSE - J = IR + 1 - ENDIF - GO TO 3 - ENDIF - JANN(I) = JA - JBNN(I) = JB - INTGRL(I) = INT - CNN(I) = CN - GO TO 2 - ENDIF -! - + IF (NCOEFF > 1) THEN +! + L = NCOEFF/2 + 1 + IR = NCOEFF + 2 CONTINUE + IF (L > 1) THEN + L = L - 1 + JA = JANN(L) + JB = JBNN(L) + INT = INTGRL(L) + CN = CNN(L) + ELSE + JA = JANN(IR) + JB = JBNN(IR) + INT = INTGRL(IR) + CN = CNN(IR) + JANN(IR) = JANN(1) + JBNN(IR) = JBNN(1) + INTGRL(IR) = INTGRL(1) + CNN(IR) = CNN(1) + IR = IR - 1 + IF (IR == 1) THEN + JANN(1) = JA + JBNN(1) = JB + INTGRL(1) = INT + CNN(1) = CN + GO TO 4 + ENDIF + ENDIF + I = L + J = L + L + 3 CONTINUE + IF (J <= IR) THEN + IF (J < IR) THEN + IF (INTGRL(J) < INTGRL(J+1)) J = J + 1 + ENDIF + IF (INT < INTGRL(J)) THEN + JANN(I) = JANN(J) + JBNN(I) = JBNN(J) + INTGRL(I) = INTGRL(J) + CNN(I) = CNN(J) + I = J + J = J + J + ELSE + J = IR + 1 + ENDIF + GO TO 3 + ENDIF + JANN(I) = JA + JBNN(I) = JB + INTGRL(I) = INT + CNN(I) = CN + GO TO 2 + ENDIF +! + ! Sorting complete; close the file ! !ww 4 CLOSE (80+NFILE) - 4 CONTINUE - NINTG = 1 - INTT = INTGRL(1) -! - DO I = 1, NCOEFF - IF (INTGRL(I) == INTT) CYCLE - INTPTR(NINTG) = I - 1 - NINTG = NINTG + 1 - INTT = INTGRL(I) - END DO - - INTPTR(NINTG) = NCOEFF -! - DO I = 1, NINTG - INTGRL(I) = INTGRL(INTPTR(I)) - END DO + 4 CONTINUE + NINTG = 1 + INTT = INTGRL(1) +! + DO I = 1, NCOEFF + IF (INTGRL(I) == INTT) CYCLE + INTPTR(NINTG) = I - 1 + NINTG = NINTG + 1 + INTT = INTGRL(I) + END DO + + INTPTR(NINTG) = NCOEFF +! + DO I = 1, NINTG + INTGRL(I) = INTGRL(INTPTR(I)) + END DO ! ! If output option is set dump the data on file ! - IF (NDUMP == 1) THEN + IF (NDUMP == 1) THEN ! ! If first set of data open the file and print ! some data to later be able to identify the file @@ -178,25 +178,25 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! ! Print out angular data for this kappa ! - WRITE (NF) NINTG, NCOEFF - DO I = 1, NINTG - WRITE (NF) INTGRL(I), INTPTR(I) - END DO - DO I = 1, NCOEFF - WRITE (NF) CNN(I), JANN(I), JBNN(I) - END DO - ENDIF - CALL DALLOC (JANN, 'JANN', 'QQSORT') - CALL DALLOC (JBNN, 'JBNN', 'QQSORT') - CALL DALLOC (INTGRL, 'INTGRL', 'QQSORT') - CALL DALLOC (CNN, 'CNN', 'QQSORT') - CALL DALLOC (INTPTR, 'INTPTR', 'QQSORT') + WRITE (NF) NINTG, NCOEFF + DO I = 1, NINTG + WRITE (NF) INTGRL(I), INTPTR(I) + END DO + DO I = 1, NCOEFF + WRITE (NF) CNN(I), JANN(I), JBNN(I) + END DO + ENDIF + CALL DALLOC (JANN, 'JANN', 'QQSORT') + CALL DALLOC (JBNN, 'JBNN', 'QQSORT') + CALL DALLOC (INTGRL, 'INTGRL', 'QQSORT') + CALL DALLOC (CNN, 'CNN', 'QQSORT') + CALL DALLOC (INTPTR, 'INTPTR', 'QQSORT') ! ! Has all data been processed? If so close ! the file ! ! IF (NFILE.EQ.KAMAX) CLOSE (NF) - + ! Debug output ! ! IF (KSTART.EQ.1) THEN @@ -215,10 +215,10 @@ SUBROUTINE QQSORT(NFILE, NUMBER, KSTART, NAME, KAMAX) ! WRITE(NNNN+NFILE,'(F12.8,2I6)') ! : (CNN(I),JANN(I),JBNN(I),I=1,NCOEFF) ! - RETURN + RETURN ! - 301 FORMAT(' T_[',1I2,',',1I2,']',' (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) - 302 FORMAT(' (',1I2,1A2,',',1I2,1A2,')',I6) - RETURN + 301 FORMAT(' T_[',1I2,',',1I2,']',' (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) + 302 FORMAT(' (',1I2,1A2,',',1I2,1A2,')',I6) + RETURN ! - END SUBROUTINE QQSORT + END SUBROUTINE QQSORT diff --git a/src/appl/rbiotransform90_mpi/qqsortmpi_I.f90 b/src/appl/rbiotransform90_mpi/qqsortmpi_I.f90 index 238a0b919..111953aec 100644 --- a/src/appl/rbiotransform90_mpi/qqsortmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/qqsortmpi_I.f90 @@ -1,14 +1,14 @@ - MODULE qqsort_I + MODULE qqsort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:38:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qqsort (NFILE, NUMBER, KSTART, NAME, KAMAX) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NUMBER - INTEGER :: KSTART - CHARACTER (LEN = 24) :: NAME - INTEGER, INTENT(IN) :: KAMAX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE qqsort (NFILE, NUMBER, KSTART, NAME, KAMAX) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NUMBER + INTEGER :: KSTART + CHARACTER (LEN = 24) :: NAME + INTEGER, INTENT(IN) :: KAMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/radfilempi.f90 b/src/appl/rbiotransform90_mpi/radfilempi.f90 index 3d06eac3c..c3a461a9b 100644 --- a/src/appl/rbiotransform90_mpi/radfilempi.f90 +++ b/src/appl/rbiotransform90_mpi/radfilempi.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE RADFILE(NAME) + SUBROUTINE RADFILE(NAME) ! * ! This subroutine outputs the transformed radial orbitals * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE grid_C USE orb_C @@ -29,36 +29,36 @@ SUBROUTINE RADFILE(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, K, I + INTEGER :: J, K, I !----------------------------------------------- ! - J = INDEX(NAME(1),' ') + J = INDEX(NAME(1),' ') OPEN(UNIT=30, FILE=NAME(1)(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - - WRITE (30) 'G92RWF' - WRITE (*, *) 'NWII', NWII - DO K = 1, NWII - WRITE (30) NPII(K), NAKII(K), EII(K), MFII(K) - WRITE (30) PZII(K), (PFII(I,K),I=1,MFII(K)), (QFII(I,K),I=1,MFII(K)) - WRITE (30) (R(I),I=1,MFII(K)) - END DO - - CLOSE(30) - - J = INDEX(NAME(2),' ') + 'UNKNOWN', POSITION='asis') + + WRITE (30) 'G92RWF' + WRITE (*, *) 'NWII', NWII + DO K = 1, NWII + WRITE (30) NPII(K), NAKII(K), EII(K), MFII(K) + WRITE (30) PZII(K), (PFII(I,K),I=1,MFII(K)), (QFII(I,K),I=1,MFII(K)) + WRITE (30) (R(I),I=1,MFII(K)) + END DO + + CLOSE(30) + + J = INDEX(NAME(2),' ') OPEN(UNIT=30, FILE=NAME(2)(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - - WRITE (30) 'G92RWF' - WRITE (*, *) 'NWFF', NWFF - DO K = 1, NWFF - WRITE (30) NPFF(K), NAKFF(K), EFF(K), MFFF(K) - WRITE (30) PZFF(K),(PFFF(I,K),I=1,MFFF(K)),(QFFF(I,K),I=1,MFFF(K)) - WRITE (30) (R(I),I=1,MFFF(K)) - END DO - - CLOSE(30) - - RETURN - END SUBROUTINE RADFILE + 'UNKNOWN', POSITION='asis') + + WRITE (30) 'G92RWF' + WRITE (*, *) 'NWFF', NWFF + DO K = 1, NWFF + WRITE (30) NPFF(K), NAKFF(K), EFF(K), MFFF(K) + WRITE (30) PZFF(K),(PFFF(I,K),I=1,MFFF(K)),(QFFF(I,K),I=1,MFFF(K)) + WRITE (30) (R(I),I=1,MFFF(K)) + END DO + + CLOSE(30) + + RETURN + END SUBROUTINE RADFILE diff --git a/src/appl/rbiotransform90_mpi/radfilempi_I.f90 b/src/appl/rbiotransform90_mpi/radfilempi_I.f90 index 826013b47..b49370b1c 100644 --- a/src/appl/rbiotransform90_mpi/radfilempi_I.f90 +++ b/src/appl/rbiotransform90_mpi/radfilempi_I.f90 @@ -1,10 +1,10 @@ - MODULE radfile_I + MODULE radfile_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE radfile (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE radfile (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/radparmpi.f90 b/src/appl/rbiotransform90_mpi/radparmpi.f90 index 6c2146ee4..e727178b3 100644 --- a/src/appl/rbiotransform90_mpi/radparmpi.f90 +++ b/src/appl/rbiotransform90_mpi/radparmpi.f90 @@ -1,18 +1,18 @@ !*********************************************************************** ! * - SUBROUTINE RADPAR + SUBROUTINE RADPAR ! * ! This subroutine sets the parameters controlling the radial grid * ! * ! Last revision: June 1996 * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE def_C, ONLY: c, cvac, z, accy USE default_C @@ -22,75 +22,75 @@ SUBROUTINE RADPAR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: YES - CHARACTER :: ANSWER + LOGICAL :: YES + CHARACTER :: ANSWER !----------------------------------------------- ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF .. should be Z-dependent RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN if (myid == 0) then - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF endif !myid=0 CALL MPI_Bcast(RNT,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast(H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast(HP,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (N, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! - - IF (NDEF /= 0) THEN + + IF (NDEF /= 0) THEN if(myid .EQ. 0) then - WRITE (6, *) 'The physical speed of light in' - WRITE (6, *) ' atomic units is', CVAC, ';' - WRITE (6, *) ' revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter the revised value:' - READ (5, *) C - ELSE - C = CVAC - ENDIF + WRITE (6, *) 'The physical speed of light in' + WRITE (6, *) ' atomic units is', CVAC, ';' + WRITE (6, *) ' revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter the revised value:' + READ (5, *) C + ELSE + C = CVAC + ENDIF endif !myid=0 CALL MPI_Bcast(C,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - ELSE - C = CVAC - ENDIF - - RETURN - END SUBROUTINE RADPAR + ELSE + C = CVAC + ENDIF + + RETURN + END SUBROUTINE RADPAR diff --git a/src/appl/rbiotransform90_mpi/radparmpi_I.f90 b/src/appl/rbiotransform90_mpi/radparmpi_I.f90 index cbb14f720..f74cd14ce 100644 --- a/src/appl/rbiotransform90_mpi/radparmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/radparmpi_I.f90 @@ -1,9 +1,9 @@ - MODULE radpar_I + MODULE radpar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE radpar - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE radpar + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/rintff.f90 b/src/appl/rbiotransform90_mpi/rintff.f90 index 8c67418d4..39af9d807 100644 --- a/src/appl/rbiotransform90_mpi/rintff.f90 +++ b/src/appl/rbiotransform90_mpi/rintff.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) ! * ! The value of RINT is an approximation to: * ! * @@ -16,51 +16,51 @@ REAL(KIND(0.0D0)) FUNCTION RINTFF (I, J, K) ! Written by Farid A Parpia, at Oxford Last updated: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFFF(I),MFFF(J)) + MTP = MIN(MFFF(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PFFF(L,I)*PFFF(L,J) + QFFF(L,I)*QFFF(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PFFF(L,I)*PFFF(L,J) + QFFF(L,I)*QFFF(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - RINTFF = RESULT + CALL QUAD (RESULT) + RINTFF = RESULT ! - RETURN + RETURN ! - END FUNCTION RINTFF + END FUNCTION RINTFF diff --git a/src/appl/rbiotransform90_mpi/rintff_I.f90 b/src/appl/rbiotransform90_mpi/rintff_I.f90 index 6ece8459b..81427bd85 100644 --- a/src/appl/rbiotransform90_mpi/rintff_I.f90 +++ b/src/appl/rbiotransform90_mpi/rintff_I.f90 @@ -1,12 +1,12 @@ - MODULE rintff_I + MODULE rintff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rintff (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintff (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/rintii.f90 b/src/appl/rbiotransform90_mpi/rintii.f90 index 71d3af7d4..c230046d5 100644 --- a/src/appl/rbiotransform90_mpi/rintii.f90 +++ b/src/appl/rbiotransform90_mpi/rintii.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) ! * ! The value of RINT is an approximation to: * ! * @@ -16,51 +16,51 @@ REAL(KIND(0.0D0)) FUNCTION RINTII (I, J, K) ! Written by Farid A Parpia, at Oxford Last updated: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFII(J)) + MTP = MIN(MFII(I),MFII(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PFII(L,I)*PFII(L,J) + QFII(L,I)*QFII(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PFII(L,I)*PFII(L,J) + QFII(L,I)*QFII(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - RINTII = RESULT + CALL QUAD (RESULT) + RINTII = RESULT ! - RETURN + RETURN ! - END FUNCTION RINTII + END FUNCTION RINTII diff --git a/src/appl/rbiotransform90_mpi/rintii_I.f90 b/src/appl/rbiotransform90_mpi/rintii_I.f90 index dc077337d..fc13eb068 100644 --- a/src/appl/rbiotransform90_mpi/rintii_I.f90 +++ b/src/appl/rbiotransform90_mpi/rintii_I.f90 @@ -1,12 +1,12 @@ - MODULE rintii_I + MODULE rintii_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rintii (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintii (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/scalve.f90 b/src/appl/rbiotransform90_mpi/scalve.f90 index 6a2c541a6..0802284bb 100644 --- a/src/appl/rbiotransform90_mpi/scalve.f90 +++ b/src/appl/rbiotransform90_mpi/scalve.f90 @@ -4,27 +4,27 @@ ! S C A L V E ! ------------------------------------------------------------------ ! - SUBROUTINE SCALVE(VECTOR, FACTOR, NDIM) + SUBROUTINE SCALVE(VECTOR, FACTOR, NDIM) ! ! CALCULATE SCALAR(FACTOR) TIMES VECTOR !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: FACTOR REAL(DOUBLE), DIMENSION(NDIM), INTENT(INOUT) :: VECTOR !----------------------------------------------- ! - VECTOR(:NDIM) = VECTOR(:NDIM)*FACTOR + VECTOR(:NDIM) = VECTOR(:NDIM)*FACTOR ! - RETURN - END SUBROUTINE SCALVE + RETURN + END SUBROUTINE SCALVE diff --git a/src/appl/rbiotransform90_mpi/scalve_I.f90 b/src/appl/rbiotransform90_mpi/scalve_I.f90 index 51e7b0550..1727fbcad 100644 --- a/src/appl/rbiotransform90_mpi/scalve_I.f90 +++ b/src/appl/rbiotransform90_mpi/scalve_I.f90 @@ -1,13 +1,13 @@ - MODULE scalve_I + MODULE scalve_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE scalve (VECTOR, FACTOR, NDIM) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE scalve (VECTOR, FACTOR, NDIM) + USE vast_kind_param,ONLY: DOUBLE REAL(DOUBLE), DIMENSION(NDIM), INTENT(INOUT) :: VECTOR - REAL(DOUBLE), INTENT(IN) :: FACTOR - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/setcslampi.f90 b/src/appl/rbiotransform90_mpi/setcslampi.f90 index cc61f0176..3dc61703b 100644 --- a/src/appl/rbiotransform90_mpi/setcslampi.f90 +++ b/src/appl/rbiotransform90_mpi/setcslampi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLA(NAME, NCORE, IGG) + SUBROUTINE SETCSLA(NAME, NCORE, IGG) !----------------------------------------------- ! * ! Open, check, load data from and close the .csl file. This file * @@ -11,57 +11,57 @@ SUBROUTINE SETCSLA(NAME, NCORE, IGG) ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslBio_I + USE openfl_I + USE lodcslBio_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE, IGG + INTEGER :: NCORE, IGG CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR, IOS - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: K, IERR, IOS + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 ! ! ! The .csl file is FORMATTED; it must exist ! - K = INDEX(NAME,' ') - FILNAM = NAME(1:K-1)//'.c' - FORM = 'FORMATTED' - STATUS = 'OLD' - + K = INDEX(NAME,' ') + FILNAM = NAME(1:K-1)//'.c' + FORM = 'FORMATTED' + STATUS = 'OLD' + ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSLBio (NCORE,IGG) + CALL LODCSLBio (NCORE,IGG) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN + RETURN END SUBROUTINE SETCSLA diff --git a/src/appl/rbiotransform90_mpi/setcslampi_I.f90 b/src/appl/rbiotransform90_mpi/setcslampi_I.f90 index b39c08b7e..835b70e54 100644 --- a/src/appl/rbiotransform90_mpi/setcslampi_I.f90 +++ b/src/appl/rbiotransform90_mpi/setcslampi_I.f90 @@ -1,11 +1,11 @@ - MODULE setcsla_I + MODULE setcsla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsla (NAME, NCORE,IGG) - CHARACTER (LEN = 24), INTENT(IN) :: NAME + SUBROUTINE setcsla (NAME, NCORE,IGG) + CHARACTER (LEN = 24), INTENT(IN) :: NAME INTEGER :: NCORE,IGG - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/setcslbmpi.f90 b/src/appl/rbiotransform90_mpi/setcslbmpi.f90 index fa475cde4..0e13c3117 100644 --- a/src/appl/rbiotransform90_mpi/setcslbmpi.f90 +++ b/src/appl/rbiotransform90_mpi/setcslbmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLB(NAME, NCORE, IGG) + SUBROUTINE SETCSLB(NAME, NCORE, IGG) !----------------------------------------------- ! * ! Open, check, load data from and close the .csl file. This file * @@ -11,55 +11,55 @@ SUBROUTINE SETCSLB(NAME, NCORE, IGG) ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslBio_I + USE openfl_I + USE lodcslBio_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE, IGG + INTEGER :: NCORE, IGG CHARACTER, INTENT(IN) :: NAME*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR, IOS - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: K, IERR, IOS + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 ! ! ! The .csl file is FORMATTED; it must exist ! - K = INDEX(NAME,' ') - FILNAM = NAME(1:K-1)//'.c' - FORM = 'FORMATTED' - STATUS = 'OLD' - + K = INDEX(NAME,' ') + FILNAM = NAME(1:K-1)//'.c' + FORM = 'FORMATTED' + STATUS = 'OLD' + ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSLBio (NCORE,IGG) + CALL LODCSLBio (NCORE,IGG) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN - END SUBROUTINE SETCSLB + RETURN + END SUBROUTINE SETCSLB diff --git a/src/appl/rbiotransform90_mpi/setcslbmpi_I.f90 b/src/appl/rbiotransform90_mpi/setcslbmpi_I.f90 index 584ecb2d6..60396b6fe 100644 --- a/src/appl/rbiotransform90_mpi/setcslbmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/setcslbmpi_I.f90 @@ -1,9 +1,9 @@ - MODULE setcslb_I + MODULE setcslb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 - SUBROUTINE setcslb (NAME, NCORE,IGG) - CHARACTER (LEN = 128), INTENT(IN) :: NAME +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 + SUBROUTINE setcslb (NAME, NCORE,IGG) + CHARACTER (LEN = 128), INTENT(IN) :: NAME INTEGER :: NCORE,IGG - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/setvec.f90 b/src/appl/rbiotransform90_mpi/setvec.f90 index 21d287c39..904ead68b 100644 --- a/src/appl/rbiotransform90_mpi/setvec.f90 +++ b/src/appl/rbiotransform90_mpi/setvec.f90 @@ -3,32 +3,32 @@ ! S E T V E C ! ------------------------------------------------------------------ ! - SUBROUTINE SETVEC(VECTOR, VALUE, NDIM) + SUBROUTINE SETVEC(VECTOR, VALUE, NDIM) ! ! VECTOR (*) = VALUE ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: VALUE + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: VALUE REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! - VECTOR(:NDIM) = VALUE + VECTOR(:NDIM) = VALUE ! - RETURN - END SUBROUTINE SETVEC + RETURN + END SUBROUTINE SETVEC diff --git a/src/appl/rbiotransform90_mpi/setvec_I.f90 b/src/appl/rbiotransform90_mpi/setvec_I.f90 index e906a2008..1fccabb99 100644 --- a/src/appl/rbiotransform90_mpi/setvec_I.f90 +++ b/src/appl/rbiotransform90_mpi/setvec_I.f90 @@ -1,13 +1,13 @@ - MODULE setvec_I + MODULE setvec_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setvec (VECTOR, VALUE, NDIM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR - REAL(DOUBLE), INTENT(IN) :: VALUE - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setvec (VECTOR, VALUE, NDIM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: VECTOR + REAL(DOUBLE), INTENT(IN) :: VALUE + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/tcsl.f90 b/src/appl/rbiotransform90_mpi/tcsl.f90 index 5e71a46a0..a59e6a6b4 100644 --- a/src/appl/rbiotransform90_mpi/tcsl.f90 +++ b/src/appl/rbiotransform90_mpi/tcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TCSL(N) + SUBROUTINE TCSL(N) ! * ! This subroutine transfers data to the initial and final state * ! common blocks * @@ -8,24 +8,24 @@ SUBROUTINE TCSL(N) ! Written by Per Jonsson Last revision: June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: N !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! ! Initial state commons @@ -34,23 +34,23 @@ SUBROUTINE TCSL(N) ! Final state commons ! ! - IF (N == 1) THEN - NCFII = NCF - NWII = NW - NPII(:NW) = NP(:NW) - NAKII(:NW) = NAK(:NW) - NKLII(:NW) = NKL(:NW) - NKJII(:NW) = NKJ(:NW) - NHII(:NW) = NH(:NW) - ELSE - NCFFF = NCF - NWFF = NW - NPFF(:NW) = NP(:NW) - NAKFF(:NW) = NAK(:NW) - NKLFF(:NW) = NKL(:NW) - NKJFF(:NW) = NKJ(:NW) - NHFF(:NW) = NH(:NW) - ENDIF - - RETURN - END SUBROUTINE TCSL + IF (N == 1) THEN + NCFII = NCF + NWII = NW + NPII(:NW) = NP(:NW) + NAKII(:NW) = NAK(:NW) + NKLII(:NW) = NKL(:NW) + NKJII(:NW) = NKJ(:NW) + NHII(:NW) = NH(:NW) + ELSE + NCFFF = NCF + NWFF = NW + NPFF(:NW) = NP(:NW) + NAKFF(:NW) = NAK(:NW) + NKLFF(:NW) = NKL(:NW) + NKJFF(:NW) = NKJ(:NW) + NHFF(:NW) = NH(:NW) + ENDIF + + RETURN + END SUBROUTINE TCSL diff --git a/src/appl/rbiotransform90_mpi/tcsl_I.f90 b/src/appl/rbiotransform90_mpi/tcsl_I.f90 index 577638d9b..9fb4dd2a9 100644 --- a/src/appl/rbiotransform90_mpi/tcsl_I.f90 +++ b/src/appl/rbiotransform90_mpi/tcsl_I.f90 @@ -1,10 +1,10 @@ - MODULE tcsl_I + MODULE tcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE tcsl (N) - INTEGER, INTENT(IN) :: N - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE tcsl (N) + INTEGER, INTENT(IN) :: N + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/ti1tv.f90 b/src/appl/rbiotransform90_mpi/ti1tv.f90 index cede07d8d..64c1c8337 100644 --- a/src/appl/rbiotransform90_mpi/ti1tv.f90 +++ b/src/appl/rbiotransform90_mpi/ti1tv.f90 @@ -29,7 +29,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -65,7 +65,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) NTEST = 000 ! IF(NTEST.GE.10) WRITE(6,*) ' Entering TI1TV' - + CALL SETVEC(CIOUT,0.0D0,NCIV*NCSF) if (NCOEFF == 0) return ! @@ -85,7 +85,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) IR = NSHLPP(L,NSHLP(L,I)) IRA = NSHLPP(L,IA) IRB = NSHLPP(L,IB) - + IF (IR.EQ.IRB.AND.IRA.LT.IRB) THEN IF (K.EQ.1) THEN IFIRST = 1 @@ -93,7 +93,7 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) IFIRST = INTPTR(K-1) + 1 ENDIF NFOUND = INTPTR(K) - IFIRST + 1 - + 15 DO IELMNT = 1, NFOUND RACAH = CNN(IFIRST-1+IELMNT) J = IRA @@ -132,6 +132,6 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) END IF ! IF(NTEST.GE.10) WRITE(6,*) ' LEAVING TI1TV' - + RETURN END diff --git a/src/appl/rbiotransform90_mpi/ti1tv_I.f90 b/src/appl/rbiotransform90_mpi/ti1tv_I.f90 index ae3050ddf..3ec10302c 100644 --- a/src/appl/rbiotransform90_mpi/ti1tv_I.f90 +++ b/src/appl/rbiotransform90_mpi/ti1tv_I.f90 @@ -1,6 +1,6 @@ - MODULE ti1tv_I + MODULE ti1tv_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) USE vast_kind_param, ONLY: DOUBLE @@ -9,6 +9,6 @@ SUBROUTINE TI1TV(CIIN,NCSF,NCIV,I,L,T,NSHL,CIOUT,NTESTG) REAL(DOUBLE), DIMENSION(ncsf, nciv), INTENT(IN) :: ciin REAL(DOUBLE), DIMENSION(nshl), INTENT(IN) :: t REAL(DOUBLE), DIMENSION(ncsf, nciv), INTENT(OUT) :: ciout - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/tiinig_I.f90 b/src/appl/rbiotransform90_mpi/tiinig_I.f90 index ed6bd5f31..4f244d31c 100644 --- a/src/appl/rbiotransform90_mpi/tiinig_I.f90 +++ b/src/appl/rbiotransform90_mpi/tiinig_I.f90 @@ -1,18 +1,18 @@ - MODULE tiinig_I + MODULE tiinig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN - INTEGER, INTENT(IN) :: NCSF - INTEGER, INTENT(IN) :: NCIV - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: L - REAL(DOUBLE), INTENT(IN) :: CONST - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN + INTEGER, INTENT(IN) :: NCSF + INTEGER, INTENT(IN) :: NCIV + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: L + REAL(DOUBLE), INTENT(IN) :: CONST + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/tiinigmpi.f90 b/src/appl/rbiotransform90_mpi/tiinigmpi.f90 index 1ba02239c..7c0747bc6 100644 --- a/src/appl/rbiotransform90_mpi/tiinigmpi.f90 +++ b/src/appl/rbiotransform90_mpi/tiinigmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) + SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! * ! Calculates the action of the operator * ! Const ** E(li,li) on a set of vectors * @@ -26,32 +26,32 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! CIOUT : List of output CI vectors * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:41:42 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:41:42 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB - USE mcpdata_C + USE mcpdata_C USE sbdat1_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setvec_I - USE wrtmat_I + USE setvec_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCSF - INTEGER :: NCIV - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: L - INTEGER, INTENT(IN) :: NTESTG - REAL(DOUBLE), INTENT(IN) :: CONST + INTEGER :: NCSF + INTEGER :: NCIV + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: L + INTEGER, INTENT(IN) :: NTESTG + REAL(DOUBLE), INTENT(IN) :: CONST REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT !----------------------------------------------- @@ -62,18 +62,18 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NTESTL, NTEST, NFOUND, K, IA, IB, IFIRST, IELMNT, IVAL, ILEFT& - , IVEC + , IVEC REAL(DOUBLE), DIMENSION(NCSF,NCIV) :: CIOUTtmp - REAL(DOUBLE) :: CONSTN + REAL(DOUBLE) :: CONSTN !----------------------------------------------- ! ! - NTESTL = 0 - NTEST = MAX(NTESTL,NTESTG) - - IF (NTEST >= 10) WRITE (6, *) ' Entering TIINI' - - CALL SETVEC (CIOUT, 0.0D0, NCSF*NCIV) + NTESTL = 0 + NTEST = MAX(NTESTL,NTESTG) + + IF (NTEST >= 10) WRITE (6, *) ' Entering TIINI' + + CALL SETVEC (CIOUT, 0.0D0, NCSF*NCIV) if (NCOEFF .EQ. 0) goto 200 ! !. Obtain address of first coupling coefficient for h(il,il) : IFIRST @@ -83,28 +83,28 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! IVAL : actual RACAH coefficient ! ILEFT = CSF(L) ? ! - NFOUND = 0 + NFOUND = 0 DO K = 1, NINTG - IA = INTGRL(K)/KEY - IB = MOD(INTGRL(K),KEY) - IF (NSHLP(L,I)/=IA .OR. IA/=IB) CYCLE - IF (K == 1) THEN - IFIRST = 1 - ELSE - IFIRST = INTPTR(K - 1) + 1 - ENDIF - NFOUND = INTPTR(K) - IFIRST + 1 - EXIT - END DO + IA = INTGRL(K)/KEY + IB = MOD(INTGRL(K),KEY) + IF (NSHLP(L,I)/=IA .OR. IA/=IB) CYCLE + IF (K == 1) THEN + IFIRST = 1 + ELSE + IFIRST = INTPTR(K - 1) + 1 + ENDIF + NFOUND = INTPTR(K) - IFIRST + 1 + EXIT + END DO - DO IELMNT = 1, NFOUND + DO IELMNT = 1, NFOUND ! Bug 2011-08-18 Per Jonsson IVAL = CNN(IFIRST-1+IELMNT) !GG IVAL = IDNINT(CNN(IFIRST-1+IELMNT)) IVAL = CNN(IFIRST-1+IELMNT) - CONSTN = CONST**IVAL - ILEFT = JANN(IFIRST - 1 + IELMNT) - CIOUT(ILEFT,:NCIV) = CONSTN*CIIN(ILEFT,:NCIV) - END DO + CONSTN = CONST**IVAL + ILEFT = JANN(IFIRST - 1 + IELMNT) + CIOUT(ILEFT,:NCIV) = CONSTN*CIIN(ILEFT,:NCIV) + END DO 200 CONTINUE call copvec(CIOUT, CIOUTtmp, NCIV*NCSF) !GG call MPI_ALLREDUCE(CIOUTtmp(1,1), CIOUT(1,1), NCIV*NCSF, & @@ -116,20 +116,20 @@ SUBROUTINE TIINIG(CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) ! For terms with vanishing occupation of il, ! just copy coefficients, since (x) ** 0 = 1 ! - WHERE (CIOUT(:NCSF,:NCIV) == 0.0D0) - CIOUT(:NCSF,:NCIV) = CIIN(:NCSF,:NCIV) - END WHERE + WHERE (CIOUT(:NCSF,:NCIV) == 0.0D0) + CIOUT(:NCSF,:NCIV) = CIIN(:NCSF,:NCIV) + END WHERE ! - IF (NTEST >= 100) THEN - WRITE (6, *) - WRITE (6, *) ' Input and output vectors from TIINI I,L', I, L - CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) - CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) - WRITE (6, *) - ENDIF + IF (NTEST >= 100) THEN + WRITE (6, *) + WRITE (6, *) ' Input and output vectors from TIINI I,L', I, L + CALL WRTMAT (CIIN, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) + CALL WRTMAT (CIOUT, NCSF, NCIV, NCSF, NCIV) + WRITE (6, *) + ENDIF ! - IF (NTEST >= 10) WRITE (6, *) ' Leaving TIINI' - - RETURN - END SUBROUTINE TIINIG + IF (NTEST >= 10) WRITE (6, *) ' Leaving TIINI' + + RETURN + END SUBROUTINE TIINIG diff --git a/src/appl/rbiotransform90_mpi/tiinigmpi_I.f90 b/src/appl/rbiotransform90_mpi/tiinigmpi_I.f90 index d4668f4a8..0dca1c9f1 100644 --- a/src/appl/rbiotransform90_mpi/tiinigmpi_I.f90 +++ b/src/appl/rbiotransform90_mpi/tiinigmpi_I.f90 @@ -1,16 +1,16 @@ - MODULE tiinig_I + MODULE tiinig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 - SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN - INTEGER, INTENT(IN) :: NCSF - INTEGER, INTENT(IN) :: NCIV - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: L - REAL(DOUBLE), INTENT(IN) :: CONST - REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT - INTEGER, INTENT(IN) :: NTESTG - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 + SUBROUTINE tiinig (CIIN, NCSF, NCIV, I, L, CONST, CIOUT, NTESTG) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(IN) :: CIIN + INTEGER, INTENT(IN) :: NCSF + INTEGER, INTENT(IN) :: NCIV + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: L + REAL(DOUBLE), INTENT(IN) :: CONST + REAL(DOUBLE), DIMENSION(NCSF,NCIV), INTENT(INOUT) :: CIOUT + INTEGER, INTENT(IN) :: NTESTG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/trpmat.f90 b/src/appl/rbiotransform90_mpi/trpmat.f90 index 19cc423dc..73e88f693 100644 --- a/src/appl/rbiotransform90_mpi/trpmat.f90 +++ b/src/appl/rbiotransform90_mpi/trpmat.f90 @@ -3,32 +3,32 @@ ! T R P M A T ! ------------------------------------------------------------------ ! - SUBROUTINE TRPMAT(XIN, NROW, NCOL, XOUT) + SUBROUTINE TRPMAT(XIN, NROW, NCOL, XOUT) ! ! XOUT(I,J) = XIN(J,I) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NROW - INTEGER , INTENT(IN) :: NCOL - REAL(DOUBLE) , INTENT(IN) :: XIN(NROW,NCOL) - REAL(DOUBLE) , INTENT(OUT) :: XOUT(NCOL,NROW) + INTEGER , INTENT(IN) :: NROW + INTEGER , INTENT(IN) :: NCOL + REAL(DOUBLE) , INTENT(IN) :: XIN(NROW,NCOL) + REAL(DOUBLE) , INTENT(OUT) :: XOUT(NCOL,NROW) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IROW, ICOL + INTEGER :: IROW, ICOL !----------------------------------------------- ! - XOUT = TRANSPOSE(XIN) + XOUT = TRANSPOSE(XIN) ! - RETURN - END SUBROUTINE TRPMAT + RETURN + END SUBROUTINE TRPMAT diff --git a/src/appl/rbiotransform90_mpi/trpmat_I.f90 b/src/appl/rbiotransform90_mpi/trpmat_I.f90 index 4be1977f9..34c7db240 100644 --- a/src/appl/rbiotransform90_mpi/trpmat_I.f90 +++ b/src/appl/rbiotransform90_mpi/trpmat_I.f90 @@ -1,14 +1,14 @@ - MODULE trpmat_I + MODULE trpmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE trpmat (XIN, NROW, NCOL, XOUT) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NROW,NCOL), INTENT(IN) :: XIN - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - REAL(DOUBLE), DIMENSION(NCOL,NROW), INTENT(OUT) :: XOUT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE trpmat (XIN, NROW, NCOL, XOUT) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NROW,NCOL), INTENT(IN) :: XIN + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + REAL(DOUBLE), DIMENSION(NCOL,NROW), INTENT(OUT) :: XOUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/ulla.f90 b/src/appl/rbiotransform90_mpi/ulla.f90 index 895eda4e0..88b3be393 100644 --- a/src/appl/rbiotransform90_mpi/ulla.f90 +++ b/src/appl/rbiotransform90_mpi/ulla.f90 @@ -3,7 +3,7 @@ ! U L L A ! ------------------------------------------------------------------ ! - SUBROUTINE ULLA(A, U, L, NDIM, SCR) + SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! Obtain U L decomposition of matrix A ! A = U L @@ -12,32 +12,32 @@ SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! Quick and dirty routine, Jeppe Olsen, November 1991 !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lulu_I - USE setvec_I - USE wrtmat_I + USE lulu_I + USE setvec_I + USE wrtmat_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDIM - REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) - REAL(DOUBLE) :: U(NDIM,NDIM) - REAL(DOUBLE) :: L(NDIM,NDIM) - REAL(DOUBLE) :: SCR(*) + INTEGER :: NDIM + REAL(DOUBLE), INTENT(IN) :: A(NDIM,NDIM) + REAL(DOUBLE) :: U(NDIM,NDIM) + REAL(DOUBLE) :: L(NDIM,NDIM) + REAL(DOUBLE) :: SCR(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KLFREE, KLPAP, I, J, KLL, KLU, IMAX, IMIN, NTEST + INTEGER :: KLFREE, KLPAP, I, J, KLL, KLU, IMAX, IMIN, NTEST !----------------------------------------------- ! ! @@ -50,45 +50,45 @@ SUBROUTINE ULLA(A, U, L, NDIM, SCR) ! ! 1 : PAP in scr(klPAP) ! - KLFREE = 1 - KLPAP = KLFREE - KLFREE = KLFREE + NDIM**2 + KLFREE = 1 + KLPAP = KLFREE + KLFREE = KLFREE + NDIM**2 ! - DO I = 1, NDIM - SCR(KLPAP-1+I:NDIM*(NDIM-1)+KLPAP-1+I:NDIM) = A(NDIM+1-I,NDIM:1:(-1)) - END DO + DO I = 1, NDIM + SCR(KLPAP-1+I:NDIM*(NDIM-1)+KLPAP-1+I:NDIM) = A(NDIM+1-I,NDIM:1:(-1)) + END DO ! 2 : Lu decompose PAP - KLL = KLFREE - KLFREE = KLFREE + NDIM*(NDIM + 1)/2 + KLL = KLFREE + KLFREE = KLFREE + NDIM*(NDIM + 1)/2 ! - KLU = KLFREE - KLFREE = KLFREE + NDIM*(NDIM + 1)/2 - CALL LULU (SCR(KLPAP), SCR(KLL), SCR(KLU), NDIM) + KLU = KLFREE + KLFREE = KLFREE + NDIM*(NDIM + 1)/2 + CALL LULU (SCR(KLPAP), SCR(KLL), SCR(KLU), NDIM) ! LULU(A,L,U,NDIM) ! Storage modes ! L(I,J) = L(I*(I-1)/2 + J ) ( I .GE. J ) ! U(I,J) = U(J*(J-1)/2 + I ) ( J .GE. I ) ! !. 3 : Obtain U as PLP and L as PUP - CALL SETVEC (U, 0.0D0, NDIM**2) - CALL SETVEC (L, 0.0D0, NDIM**2) + CALL SETVEC (U, 0.0D0, NDIM**2) + CALL SETVEC (L, 0.0D0, NDIM**2) ! - DO IMAX = 1, NDIM - DO IMIN = 1, IMAX + DO IMAX = 1, NDIM + DO IMIN = 1, IMAX U(IMIN,IMAX) = SCR(KLL-1+(NDIM+1-IMIN)*(NDIM+1-IMIN-1)/2+(NDIM+1-& - IMAX)) + IMAX)) L(IMAX,IMIN) = SCR(KLU-1+(NDIM+1-IMIN)*(NDIM+1-IMIN-1)/2+(NDIM+1-& - IMAX)) - END DO - END DO + IMAX)) + END DO + END DO ! - NTEST = 0 - IF (NTEST /= 0) THEN - WRITE (6, *) ' U and L from Ulla ' - CALL WRTMAT (U, NDIM, NDIM, NDIM, NDIM) - CALL WRTMAT (L, NDIM, NDIM, NDIM, NDIM) - ENDIF + NTEST = 0 + IF (NTEST /= 0) THEN + WRITE (6, *) ' U and L from Ulla ' + CALL WRTMAT (U, NDIM, NDIM, NDIM, NDIM) + CALL WRTMAT (L, NDIM, NDIM, NDIM, NDIM) + ENDIF ! - - RETURN - END SUBROUTINE ULLA + + RETURN + END SUBROUTINE ULLA diff --git a/src/appl/rbiotransform90_mpi/ulla_I.f90 b/src/appl/rbiotransform90_mpi/ulla_I.f90 index 36a0b74a2..187c87050 100644 --- a/src/appl/rbiotransform90_mpi/ulla_I.f90 +++ b/src/appl/rbiotransform90_mpi/ulla_I.f90 @@ -1,15 +1,15 @@ - MODULE ulla_I + MODULE ulla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ulla (A, U, L, NDIM, SCR) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: U - REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: L - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ulla (A, U, L, NDIM, SCR) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: U + REAL(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(OUT) :: L + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/vecsum.f90 b/src/appl/rbiotransform90_mpi/vecsum.f90 index 4a59e9c46..6e4c96439 100644 --- a/src/appl/rbiotransform90_mpi/vecsum.f90 +++ b/src/appl/rbiotransform90_mpi/vecsum.f90 @@ -3,46 +3,46 @@ ! V E C S U M ! ------------------------------------------------------------------ ! - SUBROUTINE VECSUM(C, A, B, FACA, FACB, NDIM) + SUBROUTINE VECSUM(C, A, B, FACA, FACB, NDIM) ! ! CACLULATE THE VECTOR C(I)=FACA*A(I)+FACB*B(I) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NDIM - REAL(DOUBLE), INTENT(IN) :: FACA - REAL(DOUBLE), INTENT(IN) :: FACB + INTEGER, INTENT(IN) :: NDIM + REAL(DOUBLE), INTENT(IN) :: FACA + REAL(DOUBLE), INTENT(IN) :: FACB REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: A REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: S + INTEGER :: I + REAL(DOUBLE) :: S !----------------------------------------------- ! - IF (FACA/=0.0D0 .AND. FACB/=0.0D0) THEN - C(:NDIM) = FACA*A(:NDIM) + FACB*B(:NDIM) + IF (FACA/=0.0D0 .AND. FACB/=0.0D0) THEN + C(:NDIM) = FACA*A(:NDIM) + FACB*B(:NDIM) ! - ELSE IF (FACA==0.0D0 .AND. FACB/=0.0D0) THEN - C(:NDIM) = FACB*B(:NDIM) + ELSE IF (FACA==0.0D0 .AND. FACB/=0.0D0) THEN + C(:NDIM) = FACB*B(:NDIM) ! - ELSE IF (FACA/=0.0D0 .AND. FACB==0.0D0) THEN - C(:NDIM) = FACA*A(:NDIM) + ELSE IF (FACA/=0.0D0 .AND. FACB==0.0D0) THEN + C(:NDIM) = FACA*A(:NDIM) ! - ELSE IF (FACA==0.0D0 .AND. FACB==0.0D0) THEN - C(:NDIM) = 0.0D0 - ENDIF + ELSE IF (FACA==0.0D0 .AND. FACB==0.0D0) THEN + C(:NDIM) = 0.0D0 + ENDIF ! - RETURN - END SUBROUTINE VECSUM + RETURN + END SUBROUTINE VECSUM diff --git a/src/appl/rbiotransform90_mpi/vecsum_I.f90 b/src/appl/rbiotransform90_mpi/vecsum_I.f90 index 8e6261b13..b1918bf98 100644 --- a/src/appl/rbiotransform90_mpi/vecsum_I.f90 +++ b/src/appl/rbiotransform90_mpi/vecsum_I.f90 @@ -1,16 +1,16 @@ - MODULE vecsum_I + MODULE vecsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vecsum (C, A, B, FACA, FACB, NDIM) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE vecsum (C, A, B, FACA, FACB, NDIM) + USE vast_kind_param,ONLY: DOUBLE REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: A REAL(DOUBLE), DIMENSION(NDIM), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(NDIM), INTENT(OUT) :: C - REAL(DOUBLE), INTENT(IN) :: FACA - REAL(DOUBLE), INTENT(IN) :: FACB - INTEGER, INTENT(IN) :: NDIM - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: FACA + REAL(DOUBLE), INTENT(IN) :: FACB + INTEGER, INTENT(IN) :: NDIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rbiotransform90_mpi/wrtmat.f90 b/src/appl/rbiotransform90_mpi/wrtmat.f90 index 83742807e..d37e1d3c9 100644 --- a/src/appl/rbiotransform90_mpi/wrtmat.f90 +++ b/src/appl/rbiotransform90_mpi/wrtmat.f90 @@ -1,35 +1,35 @@ !*********************************************************************** ! * - SUBROUTINE WRTMAT(A, NROW, NCOL, NMROW, NMCOL) + SUBROUTINE WRTMAT(A, NROW, NCOL, NMROW, NMCOL) ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:08:49 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - INTEGER, INTENT(IN) :: NMROW - INTEGER, INTENT(IN) :: NMCOL - REAL(DOUBLE), INTENT(IN) :: A(NMROW,NMCOL) + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + INTEGER, INTENT(IN) :: NMROW + INTEGER, INTENT(IN) :: NMCOL + REAL(DOUBLE), INTENT(IN) :: A(NMROW,NMCOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- - - DO I = 1, NROW - WRITE (6, 1010) I, (A(I,J),J=1,NCOL) - END DO - - 1010 FORMAT('0',I5,2X,4(1X,E14.7),/,(' ',7X,4(1X,E14.7))) - - RETURN - END SUBROUTINE WRTMAT + + DO I = 1, NROW + WRITE (6, 1010) I, (A(I,J),J=1,NCOL) + END DO + + 1010 FORMAT('0',I5,2X,4(1X,E14.7),/,(' ',7X,4(1X,E14.7))) + + RETURN + END SUBROUTINE WRTMAT diff --git a/src/appl/rbiotransform90_mpi/wrtmat_I.f90 b/src/appl/rbiotransform90_mpi/wrtmat_I.f90 index c4cb53902..103d9e97b 100644 --- a/src/appl/rbiotransform90_mpi/wrtmat_I.f90 +++ b/src/appl/rbiotransform90_mpi/wrtmat_I.f90 @@ -1,16 +1,16 @@ - MODULE wrtmat_I + MODULE wrtmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE wrtmat (A, NROW, NCOL, NMROW, NMCOL) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NMROW,NMCOL), INTENT(IN) :: A - INTEGER, INTENT(IN) :: NROW - INTEGER, INTENT(IN) :: NCOL - INTEGER, INTENT(IN) :: NMROW - INTEGER, INTENT(IN) :: NMCOL + SUBROUTINE wrtmat (A, NROW, NCOL, NMROW, NMCOL) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NMROW,NMCOL), INTENT(IN) :: A + INTEGER, INTENT(IN) :: NROW + INTEGER, INTENT(IN) :: NCOL + INTEGER, INTENT(IN) :: NMROW + INTEGER, INTENT(IN) :: NMCOL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/Makefile b/src/appl/rci90/Makefile old mode 100755 new mode 100644 index e1ce05e44..1ad902261 --- a/src/appl/rci90/Makefile +++ b/src/appl/rci90/Makefile @@ -13,7 +13,7 @@ MODLDVD = ${SRCLIBDIR}/libdvd90 MODLMPIU90 = ${SRCLIBDIR}/mpi90 GRASPLIBS = -l9290 -lmod -lrang90 -lmcp90 -ldvd90 -l9290 -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} APP_OBJ= \ iabint_I.o funk_I.o ncharg_I.o skint_I.o \ @@ -47,7 +47,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ -I $(MODDIR) -I $(MODLDVD) -I $(MODLMPIU90) -o $@ @@ -57,4 +57,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rci90/auxblk.f90 b/src/appl/rci90/auxblk.f90 index 98c5747af..36b79a293 100644 --- a/src/appl/rci90/auxblk.f90 +++ b/src/appl/rci90/auxblk.f90 @@ -1,13 +1,13 @@ -!************************************************************************ - SUBROUTINE AUXBLK(J2MAX, ATWINV) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ + SUBROUTINE AUXBLK(J2MAX, ATWINV) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE decide_C USE def_C @@ -24,87 +24,87 @@ SUBROUTINE AUXBLK(J2MAX, ATWINV) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ncharg_I - USE vacpol_I + USE ncharg_I + USE vacpol_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J2MAX - REAL(DOUBLE), INTENT(OUT) :: ATWINV + INTEGER, INTENT(IN) :: J2MAX + REAL(DOUBLE), INTENT(OUT) :: ATWINV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K - LOGICAL :: LDBPG + INTEGER :: I, K + LOGICAL :: LDBPG !----------------------------------------------- ! - FRSTCO = .TRUE. - NCOEI = 0 - - IF (LTRANS) THEN + FRSTCO = .TRUE. + NCOEI = 0 + + IF (LTRANS) THEN ! ...Check the maximum numbers of orbtitals allowed in brint.f - I = NNNW - SELECT CASE (J2MAX) - CASE (11) - I = 114 - CASE (12) - I = 112 - CASE (13) - I = 110 - CASE (14) - I = 108 - CASE (15) - I = 106 - CASE (16) - I = 105 - CASE (17) - I = 103 - CASE (18) - I = 101 - CASE (19) - I = 100 - CASE (21:) - I = 90 - END SELECT - - IF (I < NW) THEN - WRITE (ISTDE, *) 'In setham. The number of orbitals is too' - WRITE (ISTDE, *) 'large for the brint routine' - STOP - ENDIF - - FIRST = .TRUE. - NTPI = 0 - ENDIF + I = NNNW + SELECT CASE (J2MAX) + CASE (11) + I = 114 + CASE (12) + I = 112 + CASE (13) + I = 110 + CASE (14) + I = 108 + CASE (15) + I = 106 + CASE (16) + I = 105 + CASE (17) + I = 103 + CASE (18) + I = 101 + CASE (19) + I = 100 + CASE (21:) + I = 90 + END SELECT + + IF (I < NW) THEN + WRITE (ISTDE, *) 'In setham. The number of orbitals is too' + WRITE (ISTDE, *) 'large for the brint routine' + STOP + ENDIF + + FIRST = .TRUE. + NTPI = 0 + ENDIF ! ! Initialisations for the vacuum polarisation corrections ! - IF (LVP) THEN - CALL NCHARG - CALL VACPOL - ZDIST(2:N) = TB(2:N)*RP(2:N) - FRSTVP = .TRUE. - NVPI = 0 - ENDIF + IF (LVP) THEN + CALL NCHARG + CALL VACPOL + ZDIST(2:N) = TB(2:N)*RP(2:N) + FRSTVP = .TRUE. + NVPI = 0 + ENDIF ! ! Initialisations for nuclear translational energy corrections ! - IF (EMN > 0.D0) THEN - ATWINV = 1.D0/EMN - IF (LNMS) THEN - FRSTKI = .TRUE. - NKEI = 0 - ENDIF - IF (LSMS) THEN - FRSTVI = .TRUE. - NVINTI = 0 - ENDIF - ELSE + IF (EMN > 0.D0) THEN + ATWINV = 1.D0/EMN + IF (LNMS) THEN + FRSTKI = .TRUE. + NKEI = 0 + ENDIF + IF (LSMS) THEN + FRSTVI = .TRUE. + NVINTI = 0 + ENDIF + ELSE ! atwinv will not be used - LNMS = .FALSE. - LSMS = .FALSE. - ENDIF - - RETURN - END SUBROUTINE AUXBLK + LNMS = .FALSE. + LSMS = .FALSE. + ENDIF + + RETURN + END SUBROUTINE AUXBLK diff --git a/src/appl/rci90/auxblk_I.f90 b/src/appl/rci90/auxblk_I.f90 index c4b6cea41..a94227794 100644 --- a/src/appl/rci90/auxblk_I.f90 +++ b/src/appl/rci90/auxblk_I.f90 @@ -1,12 +1,12 @@ - MODULE auxblk_I + MODULE auxblk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE auxblk (J2MAX, ATWINV) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J2MAX - REAL(DOUBLE), INTENT(OUT) :: ATWINV - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE auxblk (J2MAX, ATWINV) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J2MAX + REAL(DOUBLE), INTENT(OUT) :: ATWINV + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/bessel.f90 b/src/appl/rci90/bessel.f90 index 3aa8eb7a8..14013bc83 100644 --- a/src/appl/rci90/bessel.f90 +++ b/src/appl/rci90/bessel.f90 @@ -1,8 +1,8 @@ !*********************************************************************** ! * - SUBROUTINE BESSEL(IA, IB, IK, IW, K) + SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- ! * ! This routine evaluates the functions * @@ -37,13 +37,13 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M O D U L E S !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE bess_C USE debug_C @@ -56,11 +56,11 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: IW - INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: IW + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- @@ -68,174 +68,174 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ICODE, IWKP, IKKP, L, I, NN, J, JCHAN, IREM, ISWAP + INTEGER :: ICODE, IWKP, IKKP, L, I, NN, J, JCHAN, IREM, ISWAP REAL(DOUBLE) :: EPSI, W, WA, XBESS1, XBESS2, S1, S2, DFNM, DFN, SSN, SCN& - , SN, CN, OBWA, B, SKEEP + , SN, CN, OBWA, B, SKEEP !----------------------------------------------- ! - EPSI = SQRT(0.1D00*ACCY) + EPSI = SQRT(0.1D00*ACCY) ! ! Form unique label symmetric in IA, IB ! - ICODE = MAX(IA,IB) + KEY*(MIN(IA,IB) + KEY*K) + ICODE = MAX(IA,IB) + KEY*(MIN(IA,IB) + KEY*K) ! ! Function in position; return ! - IF (ICODE == KEEP(IK,IW)) RETURN + IF (ICODE == KEEP(IK,IW)) RETURN ! ! Function not in position; is it available in BESS arrays? ! - W = WFACT*ABS(E(IA)-E(IB))/C - WIJ(IW) = W + W = WFACT*ABS(E(IA)-E(IB))/C + WIJ(IW) = W ! - DO IWKP = 1, 2 - DO IKKP = 1, 2 - IF (KEEP(IKKP,IWKP) /= ICODE) CYCLE + DO IWKP = 1, 2 + DO IKKP = 1, 2 + IF (KEEP(IKKP,IWKP) /= ICODE) CYCLE ! ! Function found move into position ! - KEEP(IK,IW) = ICODE + KEEP(IK,IW) = ICODE IF (LDBPR(7)) WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB), K, & - IKKP, IWKP, IK, IW - BESSJ(IK,IW,:N) = BESSJ(IKKP,IWKP,:N) - BESSN(IK,IW,:N) = BESSN(IKKP,IWKP,:N) - RETURN - END DO - END DO + IKKP, IWKP, IK, IW + BESSJ(IK,IW,:N) = BESSJ(IKKP,IWKP,:N) + BESSN(IK,IW,:N) = BESSN(IKKP,IWKP,:N) + RETURN + END DO + END DO ! ! Function not found; evaluate it ! - IF (LDBPR(7)) WRITE (99, 303) NP(IA), NH(IA), NP(IB), NH(IB), K, IK, IW + IF (LDBPR(7)) WRITE (99, 303) NP(IA), NH(IA), NP(IB), NH(IB), K, IK, IW ! - KEEP(IK,IW) = ICODE + KEEP(IK,IW) = ICODE ! - IF (W < EPSI**2) THEN + IF (W < EPSI**2) THEN ! ! Negligible w ! - BESSJ(IK,IW,:N) = 0.0D00 - BESSN(IK,IW,:N) = 0.0D00 - RETURN + BESSJ(IK,IW,:N) = 0.0D00 + BESSN(IK,IW,:N) = 0.0D00 + RETURN ! - ENDIF + ENDIF ! - NN = K + NN = K ! - BESSJ(IK,IW,1) = 0.0D00 - BESSN(IK,IW,1) = 0.0D00 + BESSJ(IK,IW,1) = 0.0D00 + BESSN(IK,IW,1) = 0.0D00 ! ! Use a four-term power series for low w*r ! - L5: DO J = 2, N - WA = -0.5D00*(R(J)*W)**2 - XBESS1 = 1.0D00 - XBESS2 = 1.0D00 - S1 = 0.0D00 - S2 = 0.0D00 - DO I = 1, 4 - XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) - XBESS2 = XBESS2*WA/DBLE(I*(2*(I - NN) - 1)) - S1 = S1 + XBESS1 - S2 = S2 + XBESS2 + L5: DO J = 2, N + WA = -0.5D00*(R(J)*W)**2 + XBESS1 = 1.0D00 + XBESS2 = 1.0D00 + S1 = 0.0D00 + S2 = 0.0D00 + DO I = 1, 4 + XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) + XBESS2 = XBESS2*WA/DBLE(I*(2*(I - NN) - 1)) + S1 = S1 + XBESS1 + S2 = S2 + XBESS2 IF (ABS(XBESS1)>=ABS(S1)*EPSI .OR. ABS(XBESS2)>=ABS(S2)*EPSI) & - CYCLE - BESSJ(IK,IW,J) = S1 - BESSN(IK,IW,J) = S2 - CYCLE L5 - END DO - JCHAN = J - GO TO 6 - END DO L5 + CYCLE + BESSJ(IK,IW,J) = S1 + BESSN(IK,IW,J) = S2 + CYCLE L5 + END DO + JCHAN = J + GO TO 6 + END DO L5 ! ! If here then calculated whole array using four-term power ! series. Hence return ! - RETURN + RETURN ! ! Use sin/cos expansion when power series requires more than ! four terms terms to converge ! - 6 CONTINUE - IF (NN == 0) THEN - DFNM = 1.0D00 - DFN = 1.0D00 - ELSE - DFNM = 1.0D00 - DO I = 3, 2*NN - 1, 2 - DFNM = DFNM*DBLE(I) - END DO - DFN = DFNM*DBLE(2*NN + 1) - ENDIF - DFNM = 1.0D00/DFNM + 6 CONTINUE + IF (NN == 0) THEN + DFNM = 1.0D00 + DFN = 1.0D00 + ELSE + DFNM = 1.0D00 + DO I = 3, 2*NN - 1, 2 + DFNM = DFNM*DBLE(I) + END DO + DFN = DFNM*DBLE(2*NN + 1) + ENDIF + DFNM = 1.0D00/DFNM ! - IREM = MOD(NN,4) + IREM = MOD(NN,4) ! - SELECT CASE (IREM) - CASE (1) + SELECT CASE (IREM) + CASE (1) ! ! NN = 1, 5, 9, ... ! - SSN = -1.0D00 - SCN = 1.0D00 - ISWAP = 1 + SSN = -1.0D00 + SCN = 1.0D00 + ISWAP = 1 ! - CASE (2) + CASE (2) ! ! N = 2, 6, 10, .... ! - SSN = -1.0D00 - SCN = -1.0D00 - ISWAP = 0 + SSN = -1.0D00 + SCN = -1.0D00 + ISWAP = 0 ! - CASE (3) + CASE (3) ! ! NN = 3, 7, 11,... ! - SSN = 1.0D00 - SCN = -1.0D00 - ISWAP = 1 + SSN = 1.0D00 + SCN = -1.0D00 + ISWAP = 1 ! - CASE DEFAULT + CASE DEFAULT ! ! NN = 0, 4, 8,... ! - SSN = 1.0D00 - SCN = 1.0D00 - ISWAP = 0 -! - END SELECT -! - DO J = JCHAN, N - WA = W*R(J) - IF (ISWAP == 0) THEN - SN = SSN*SIN(WA) - CN = SCN*COS(WA) - ELSE - SN = SSN*COS(WA) - CN = SCN*SIN(WA) - ENDIF - OBWA = 1.0D00/WA - B = OBWA - S1 = B*SN - S2 = B*CN - DO I = 1, NN - SKEEP = SN - SN = CN - CN = -SKEEP - B = B*OBWA*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I) - S1 = S1 + B*SN - S2 = S2 + B*CN - END DO - S1 = S1*DFN/WA**NN - 1.0D00 - S2 = S2*WA**(NN + 1)*DFNM - 1.0D00 - BESSJ(IK,IW,J) = S1 - BESSN(IK,IW,J) = S2 - END DO - RETURN -! - 303 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'New',6X,'(',I2,',',I2,')') + SSN = 1.0D00 + SCN = 1.0D00 + ISWAP = 0 +! + END SELECT +! + DO J = JCHAN, N + WA = W*R(J) + IF (ISWAP == 0) THEN + SN = SSN*SIN(WA) + CN = SCN*COS(WA) + ELSE + SN = SSN*COS(WA) + CN = SCN*SIN(WA) + ENDIF + OBWA = 1.0D00/WA + B = OBWA + S1 = B*SN + S2 = B*CN + DO I = 1, NN + SKEEP = SN + SN = CN + CN = -SKEEP + B = B*OBWA*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I) + S1 = S1 + B*SN + S2 = S2 + B*CN + END DO + S1 = S1*DFN/WA**NN - 1.0D00 + S2 = S2*WA**(NN + 1)*DFNM - 1.0D00 + BESSJ(IK,IW,J) = S1 + BESSN(IK,IW,J) = S2 + END DO + RETURN +! + 303 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'New',6X,'(',I2,',',I2,')') 302 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'(',I2,',',I2,')',2X,'(',I2,',',I2,')'& - ) - RETURN + ) + RETURN ! - END SUBROUTINE BESSEL + END SUBROUTINE BESSEL diff --git a/src/appl/rci90/bessel_I.f90 b/src/appl/rci90/bessel_I.f90 index 1da0cc215..c31c1c7c4 100644 --- a/src/appl/rci90/bessel_I.f90 +++ b/src/appl/rci90/bessel_I.f90 @@ -1,14 +1,14 @@ - MODULE bessel_I + MODULE bessel_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bessel (IA, IB, IK, IW, K) - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: IW - INTEGER, INTENT(IN) :: K - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bessel (IA, IB, IK, IW, K) + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: IW + INTEGER, INTENT(IN) :: K + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/breid.f90 b/src/appl/rci90/breid.f90 index ed9eac061..884d8c158 100644 --- a/src/appl/rci90/breid.f90 +++ b/src/appl/rci90/breid.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) + SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) ! * ! Computes closed shell contributions - aaaa and exchange only. * ! * @@ -9,13 +9,13 @@ SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) ! LAST UPDATE: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bcore_C USE cons_C USE debug_C @@ -24,162 +24,162 @@ SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE snrc_I - USE clrx_I - USE talk_I - USE itrig_I - USE cxk_I + USE snrc_I + USE clrx_I + USE talk_I + USE itrig_I + USE cxk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 + INTEGER :: JA + INTEGER :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NUMAX = 20 + INTEGER, PARAMETER :: NUMAX = 20 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(4) :: JS, KAPS, KS + INTEGER, DIMENSION(4) :: JS, KAPS, KS INTEGER :: IA1, IB1, ISG, NQS1, NQS2, I, ND1, ND2, NE1, NE2, IBRD, IBRE, & - N, NU, K, KAP1, ITYPE, MU, IP, IPP, KK, NUP1 - REAL(DOUBLE), DIMENSION(7,20) :: CONE - REAL(DOUBLE), DIMENSION(12) :: S - REAL(DOUBLE) :: CONST, GAM, DKSKS, DNUNU1, COEF, PROC, PROD + N, NU, K, KAP1, ITYPE, MU, IP, IPP, KK, NUP1 + REAL(DOUBLE), DIMENSION(7,20) :: CONE + REAL(DOUBLE), DIMENSION(12) :: S + REAL(DOUBLE) :: CONST, GAM, DKSKS, DNUNU1, COEF, PROC, PROD !----------------------------------------------- ! ! 1.0 Initialization ! - IF (IPCA == 2) THEN - IA1 = KLIST(JA1) - ELSE - IA1 = JLIST(JA1) - ENDIF - IB1 = KLIST(JB1) -! - ISG = 1 - IF (JA == JB) THEN - IF (ICORE(IA1)/=0 .AND. ICORE(IB1)/=0) THEN - IF (JA > 1) RETURN - ISG = -1 - ENDIF - ENDIF -! - JS(1) = IA1 - JS(2) = IB1 - JS(3) = IA1 - JS(4) = IB1 - NQS1 = NQ1(IA1) - NQS2 = NQ2(IB1) - DO I = 1, 4 - KAPS(I) = 2*NAK(JS(I)) - KS(I) = IABS(KAPS(I)) - END DO - CONST = NQS1*NQS2 - IF (IBUG2 /= 0) WRITE (99, 300) IA1, IB1 + IF (IPCA == 2) THEN + IA1 = KLIST(JA1) + ELSE + IA1 = JLIST(JA1) + ENDIF + IB1 = KLIST(JB1) +! + ISG = 1 + IF (JA == JB) THEN + IF (ICORE(IA1)/=0 .AND. ICORE(IB1)/=0) THEN + IF (JA > 1) RETURN + ISG = -1 + ENDIF + ENDIF +! + JS(1) = IA1 + JS(2) = IB1 + JS(3) = IA1 + JS(4) = IB1 + NQS1 = NQ1(IA1) + NQS2 = NQ2(IB1) + DO I = 1, 4 + KAPS(I) = 2*NAK(JS(I)) + KS(I) = IABS(KAPS(I)) + END DO + CONST = NQS1*NQS2 + IF (IBUG2 /= 0) WRITE (99, 300) IA1, IB1 ! ! 2.0 Set range of tensor indices ! - CALL SNRC (JS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) - IF (IBUG2 /= 0) WRITE (99, 301) ND1, ND2, NE1, NE2, IBRD, IBRE - IF (IA1 == IB1) THEN + CALL SNRC (JS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + IF (IBUG2 /= 0) WRITE (99, 301) ND1, ND2, NE1, NE2, IBRD, IBRE + IF (IA1 == IB1) THEN ! ! 3.0 Calculate aaaa interaction ! - DO N = 1, ND2 - NU = ND1 + 2*(N - 1) - K = NU - IF (MOD(K,2) /= 1) RETURN - KAP1 = KAPS(1)/2 - GAM = CLRX(KAP1,NU,KAP1) - DKSKS = KS(1)*KS(1) - DNUNU1 = NU*(NU + 1) - COEF = CONST*TWO*DKSKS*GAM*GAM/DNUNU1 - IF (IBUG2 /= 0) WRITE (99, 302) NU, GAM, COEF - ITYPE = ISG*4 - CALL TALK (JA, JB, NU, IA1, IA1, IA1, IA1, ITYPE, COEF) - END DO - RETURN - ENDIF + DO N = 1, ND2 + NU = ND1 + 2*(N - 1) + K = NU + IF (MOD(K,2) /= 1) RETURN + KAP1 = KAPS(1)/2 + GAM = CLRX(KAP1,NU,KAP1) + DKSKS = KS(1)*KS(1) + DNUNU1 = NU*(NU + 1) + COEF = CONST*TWO*DKSKS*GAM*GAM/DNUNU1 + IF (IBUG2 /= 0) WRITE (99, 302) NU, GAM, COEF + ITYPE = ISG*4 + CALL TALK (JA, JB, NU, IA1, IA1, IA1, IA1, ITYPE, COEF) + END DO + RETURN + ENDIF ! ! Calculate exchange interactions ! - IF (IBRE < 0) RETURN - IF (NE2 > NUMAX) THEN - WRITE (*, 304) - STOP - ENDIF + IF (IBRE < 0) RETURN + IF (NE2 > NUMAX) THEN + WRITE (*, 304) + STOP + ENDIF ! - CONE(:,:NE2) = ZERO + CONE(:,:NE2) = ZERO ! - PROC = -CONST/DBLE(KS(1)*KS(2)) + PROC = -CONST/DBLE(KS(1)*KS(2)) ! ! Negative sign arises from Pauli phase factor ! - DO N = 1, NE2 - NU = NE1 + 2*(N - 1) - K = NU - IP = (KS(1)-KS(2))/2 + K - IPP = IP + 1 - IF (NU /= 0) THEN - KK = K + K + 1 - IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN - PROD = PROC - IF (MOD(IP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) - CONE(:3,N) = CONE(:3,N) + PROD*S(:3) - ENDIF -! - K = NU - 1 - KK = K + K + 1 - IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN - PROD = PROC - IF (MOD(IPP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) - CONE(:3,N) = CONE(:3,N) + PROD*S(:3) -! - ENDIF - ENDIF - IF (N == NE2) EXIT - K = NU + 1 - KK = K + K + 1 - PROD = PROC - IF (MOD(IPP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,7) - CONE(:,N) = CONE(:,N) + PROD*S(:7) - END DO + DO N = 1, NE2 + NU = NE1 + 2*(N - 1) + K = NU + IP = (KS(1)-KS(2))/2 + K + IPP = IP + 1 + IF (NU /= 0) THEN + KK = K + K + 1 + IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN + PROD = PROC + IF (MOD(IP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) + CONE(:3,N) = CONE(:3,N) + PROD*S(:3) + ENDIF +! + K = NU - 1 + KK = K + K + 1 + IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN + PROD = PROC + IF (MOD(IPP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) + CONE(:3,N) = CONE(:3,N) + PROD*S(:3) +! + ENDIF + ENDIF + IF (N == NE2) EXIT + K = NU + 1 + KK = K + K + 1 + PROD = PROC + IF (MOD(IPP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,7) + CONE(:,N) = CONE(:,N) + PROD*S(:7) + END DO ! ! 4.0 Output results ! - DO N = 1, NE2 - NU = NE1 + 2*(N - 1) - ITYPE = ISG*5 - CALL TALK (JA, JB, NU, IB1, IA1, IB1, IA1, ITYPE, CONE(1,N)) - CALL TALK (JA, JB, NU, IA1, IB1, IB1, IA1, ITYPE, CONE(2,N)) - CALL TALK (JA, JB, NU, IA1, IB1, IA1, IB1, ITYPE, CONE(3,N)) - IF (N == NE2) CYCLE - NUP1 = NU + 1 - ITYPE = ISG*6 - CALL TALK (JA, JB, NUP1, IA1, IB1, IA1, IB1, ITYPE, CONE(4,N)) - CALL TALK (JA, JB, NUP1, IB1, IA1, IB1, IA1, ITYPE, CONE(5,N)) - CALL TALK (JA, JB, NUP1, IA1, IB1, IB1, IA1, ITYPE, CONE(6,N)) - CALL TALK (JA, JB, NUP1, IB1, IA1, IA1, IB1, ITYPE, CONE(7,N)) - END DO - RETURN -! - 300 FORMAT('BREID: orbitals ',2I3) - 301 FORMAT(2X,'ND1 ND2 NE1 NE2 IBRD IBRE ',6I5) - 302 FORMAT(2X,'aaaa contribution: NU,GAM,COEF',I5,2(3X,1P,D15.8)) - 303 FORMAT(2X,'PROD = ',1P,D15.8,/,' S',7D15.8) - 304 FORMAT('BREID: Dimension error for NUMAX.') - RETURN -! - END SUBROUTINE BREID + DO N = 1, NE2 + NU = NE1 + 2*(N - 1) + ITYPE = ISG*5 + CALL TALK (JA, JB, NU, IB1, IA1, IB1, IA1, ITYPE, CONE(1,N)) + CALL TALK (JA, JB, NU, IA1, IB1, IB1, IA1, ITYPE, CONE(2,N)) + CALL TALK (JA, JB, NU, IA1, IB1, IA1, IB1, ITYPE, CONE(3,N)) + IF (N == NE2) CYCLE + NUP1 = NU + 1 + ITYPE = ISG*6 + CALL TALK (JA, JB, NUP1, IA1, IB1, IA1, IB1, ITYPE, CONE(4,N)) + CALL TALK (JA, JB, NUP1, IB1, IA1, IB1, IA1, ITYPE, CONE(5,N)) + CALL TALK (JA, JB, NUP1, IA1, IB1, IB1, IA1, ITYPE, CONE(6,N)) + CALL TALK (JA, JB, NUP1, IB1, IA1, IA1, IB1, ITYPE, CONE(7,N)) + END DO + RETURN +! + 300 FORMAT('BREID: orbitals ',2I3) + 301 FORMAT(2X,'ND1 ND2 NE1 NE2 IBRD IBRE ',6I5) + 302 FORMAT(2X,'aaaa contribution: NU,GAM,COEF',I5,2(3X,1P,D15.8)) + 303 FORMAT(2X,'PROD = ',1P,D15.8,/,' S',7D15.8) + 304 FORMAT('BREID: Dimension error for NUMAX.') + RETURN +! + END SUBROUTINE BREID diff --git a/src/appl/rci90/breid_I.f90 b/src/appl/rci90/breid_I.f90 index 7d27298c3..b2eb24e5d 100644 --- a/src/appl/rci90/breid_I.f90 +++ b/src/appl/rci90/breid_I.f90 @@ -1,14 +1,14 @@ - MODULE breid_I + MODULE breid_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE breid (JA, JB, JA1, IPCA, JB1) - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE breid (JA, JB, JA1, IPCA, JB1) + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/brint1.f90 b/src/appl/rci90/brint1.f90 index 08affb3b0..b21515d9b 100644 --- a/src/appl/rci90/brint1.f90 +++ b/src/appl/rci90/brint1.f90 @@ -7,7 +7,7 @@ SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) ! Written by Per Jonsson Octaober 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint1_I.f90 b/src/appl/rci90/brint1_I.f90 index eea131bdf..037526de6 100644 --- a/src/appl/rci90/brint1_I.f90 +++ b/src/appl/rci90/brint1_I.f90 @@ -1,6 +1,6 @@ - MODULE brint1_I + MODULE brint1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -8,4 +8,4 @@ SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brint2.f90 b/src/appl/rci90/brint2.f90 index 8250e4bfd..44f31bd4f 100644 --- a/src/appl/rci90/brint2.f90 +++ b/src/appl/rci90/brint2.f90 @@ -7,7 +7,7 @@ SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) ! Written by Per Jonsson Octaober 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint2_I.f90 b/src/appl/rci90/brint2_I.f90 index 1bdf02286..98be10bd7 100644 --- a/src/appl/rci90/brint2_I.f90 +++ b/src/appl/rci90/brint2_I.f90 @@ -1,6 +1,6 @@ - MODULE brint2_I + MODULE brint2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -8,4 +8,4 @@ SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brint3.f90 b/src/appl/rci90/brint3.f90 index cf28997ad..3599e5643 100644 --- a/src/appl/rci90/brint3.f90 +++ b/src/appl/rci90/brint3.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint3_I.f90 b/src/appl/rci90/brint3_I.f90 index 925807a9f..4e1ab8ee8 100644 --- a/src/appl/rci90/brint3_I.f90 +++ b/src/appl/rci90/brint3_I.f90 @@ -1,7 +1,7 @@ - MODULE brint3_I + MODULE brint3_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brint4.f90 b/src/appl/rci90/brint4.f90 index f331d52b5..5ec66c9ad 100644 --- a/src/appl/rci90/brint4.f90 +++ b/src/appl/rci90/brint4.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint4_I.f90 b/src/appl/rci90/brint4_I.f90 index 43bd4b3de..6a5d76cd2 100644 --- a/src/appl/rci90/brint4_I.f90 +++ b/src/appl/rci90/brint4_I.f90 @@ -1,7 +1,7 @@ - MODULE brint4_I + MODULE brint4_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brint5.f90 b/src/appl/rci90/brint5.f90 index 52cc9d8fc..540074e57 100644 --- a/src/appl/rci90/brint5.f90 +++ b/src/appl/rci90/brint5.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint5_I.f90 b/src/appl/rci90/brint5_I.f90 index 800cacd8e..74edf74ac 100644 --- a/src/appl/rci90/brint5_I.f90 +++ b/src/appl/rci90/brint5_I.f90 @@ -1,7 +1,7 @@ - MODULE brint5_I + MODULE brint5_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brint6.f90 b/src/appl/rci90/brint6.f90 index e15c52eef..1e0a11fd0 100644 --- a/src/appl/rci90/brint6.f90 +++ b/src/appl/rci90/brint6.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/brint6_I.f90 b/src/appl/rci90/brint6_I.f90 index 155f6ce79..72e457de7 100644 --- a/src/appl/rci90/brint6_I.f90 +++ b/src/appl/rci90/brint6_I.f90 @@ -1,7 +1,7 @@ - MODULE brint6_I + MODULE brint6_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90/brintf.f90 b/src/appl/rci90/brintf.f90 index 4229f70cf..9c026266c 100644 --- a/src/appl/rci90/brintf.f90 +++ b/src/appl/rci90/brintf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) + REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) ! * ! Computes integrals for the transverse photon interaction. * ! * @@ -9,89 +9,89 @@ REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: KEYORB USE stor_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE bessel_I - USE brra_I + USE bessel_I + USE brra_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ITYPE - INTEGER :: IA - INTEGER :: IB - INTEGER :: IC - INTEGER :: ID - INTEGER :: K + INTEGER :: ITYPE + INTEGER :: IA + INTEGER :: IB + INTEGER :: IC + INTEGER :: ID + INTEGER :: K !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: KEY2 = KEY*KEY + INTEGER, PARAMETER :: KEY2 = KEY*KEY !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ICOD, ICOD1, ICOD2, ICOD3, ICOD4 + INTEGER :: ICOD, ICOD1, ICOD2, ICOD3, ICOD4 !----------------------------------------------- ! - GO TO (1,4,3,6,2,5) ITYPE + GO TO (1,4,3,6,2,5) ITYPE ! ! Type 1 and 5 integrals require j(k), n(k) Bessel fuctions ! Type 5 integrals only require w = wab Bessel functions ! - 1 CONTINUE + 1 CONTINUE IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC==IB) CALL BESSEL (IC, ID, 1, 2& - , K) - 2 CONTINUE - CALL BESSEL (IA, IB, 1, 1, K) - GO TO 6 + , K) + 2 CONTINUE + CALL BESSEL (IA, IB, 1, 1, K) + GO TO 6 ! ! Type 3 integrals require j(k), n(k) Bessel functions for either ! w = wab or w = cd whichever is non-zero. ! - 3 CONTINUE - IF (IA /= IB) CALL BESSEL (IA, IB, 1, 1, K) - IF (IC /= ID) CALL BESSEL (IC, ID, 1, 2, K) - GO TO 6 + 3 CONTINUE + IF (IA /= IB) CALL BESSEL (IA, IB, 1, 1, K) + IF (IC /= ID) CALL BESSEL (IC, ID, 1, 2, K) + GO TO 6 ! ! Type 2 and 6 integrals require j(k), n(k) and j(k+2), n(k+2) ! Bessel fuctions ! Type 6 integrals only require w = wab Bessel functions. ! - 4 CONTINUE - IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC/=IB) THEN + 4 CONTINUE + IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC/=IB) THEN ! - ICOD = MAX(IC,ID) + KEY*MIN(IC,ID) - ICOD1 = ICOD + KEY2*(K - 1) - ICOD2 = ICOD + KEY2*(K + 1) - ICOD = MAX(IA,IB) + KEY*MIN(IA,IB) - ICOD3 = ICOD + KEY2*(K - 1) - ICOD4 = ICOD + KEY2*(K + 1) + ICOD = MAX(IC,ID) + KEY*MIN(IC,ID) + ICOD1 = ICOD + KEY2*(K - 1) + ICOD2 = ICOD + KEY2*(K + 1) + ICOD = MAX(IA,IB) + KEY*MIN(IA,IB) + ICOD3 = ICOD + KEY2*(K - 1) + ICOD4 = ICOD + KEY2*(K + 1) IF (ICOD1==KEEP(1,2) .AND. ICOD2==KEEP(2,2) .AND. ICOD3==KEEP(1,1)& - .AND. ICOD4==KEEP(2,1)) GO TO 6 + .AND. ICOD4==KEEP(2,1)) GO TO 6 IF (ICOD1==KEEP(1,1) .AND. ICOD2==KEEP(2,1) .AND. ICOD3==KEEP(1,2)& - .AND. ICOD4==KEEP(2,2)) GO TO 6 - CALL BESSEL (IC, ID, 1, 2, K - 1) - CALL BESSEL (IC, ID, 2, 2, K + 1) - ENDIF + .AND. ICOD4==KEEP(2,2)) GO TO 6 + CALL BESSEL (IC, ID, 1, 2, K - 1) + CALL BESSEL (IC, ID, 2, 2, K + 1) + ENDIF ! - 5 CONTINUE - CALL BESSEL (IA, IB, 1, 1, K - 1) - CALL BESSEL (IA, IB, 2, 1, K + 1) + 5 CONTINUE + CALL BESSEL (IA, IB, 1, 1, K - 1) + CALL BESSEL (IA, IB, 2, 1, K + 1) ! ! Compute the integral ! - 6 CONTINUE - BRINTF = BRRA(ITYPE,IA,IB,IC,ID,K) + 6 CONTINUE + BRINTF = BRRA(ITYPE,IA,IB,IC,ID,K) ! - RETURN - END FUNCTION BRINTF + RETURN + END FUNCTION BRINTF diff --git a/src/appl/rci90/brintf_I.f90 b/src/appl/rci90/brintf_I.f90 index 5d0a847fd..e9de88d61 100644 --- a/src/appl/rci90/brintf_I.f90 +++ b/src/appl/rci90/brintf_I.f90 @@ -1,15 +1,15 @@ - MODULE brintf_I + MODULE brintf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION brintf (ITYPE, IA, IB, IC, ID, K) - INTEGER, INTENT(IN) :: ITYPE - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION brintf (ITYPE, IA, IB, IC, ID, K) + INTEGER, INTENT(IN) :: ITYPE + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/brra.f90 b/src/appl/rci90/brra.f90 index 5fc8f2994..6f22888fa 100644 --- a/src/appl/rci90/brra.f90 +++ b/src/appl/rci90/brra.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) + REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) ! * ! This routine evaluates the transverse interaction integrals: * ! * @@ -16,13 +16,13 @@ REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE cons_C USE grid_C @@ -30,97 +30,97 @@ REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rkint_I - USE skint_I + USE rkint_I + USE skint_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: IA - INTEGER :: IC - INTEGER :: IB - INTEGER :: ID - INTEGER :: K + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: IA + INTEGER :: IC + INTEGER :: IB + INTEGER :: ID + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRAC, I, MXRBD - REAL(DOUBLE), DIMENSION(NNNP) :: RAC, RBD + INTEGER :: MXRAC, I, MXRBD + REAL(DOUBLE), DIMENSION(NNNP) :: RAC, RBD !----------------------------------------------- ! - MXRAC = MIN(MF(IA),MF(IC)) - DO I = 1, MXRAC - RAC(I) = PF(I,IA)*QF(I,IC) - END DO + MXRAC = MIN(MF(IA),MF(IC)) + DO I = 1, MXRAC + RAC(I) = PF(I,IA)*QF(I,IC) + END DO ! - MXRBD = MIN(MF(IB),MF(ID)) - DO I = 1, MXRBD - RBD(I) = PF(I,IB)*QF(I,ID) - END DO + MXRBD = MIN(MF(IB),MF(ID)) + DO I = 1, MXRBD + RBD(I) = PF(I,IB)*QF(I,ID) + END DO ! - GO TO (21,22,23,24,25,26) ITYPE + GO TO (21,22,23,24,25,26) ITYPE ! ! ITYPE = 1 ! - 21 CONTINUE - IF (IA==IB .AND. IC==ID) GO TO 9 - IF (IA==ID .AND. IC==IB) GO TO 10 + 21 CONTINUE + IF (IA==IB .AND. IC==ID) GO TO 9 + IF (IA==ID .AND. IC==IB) GO TO 10 BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RAC,IA,IC,RBD,IB,ID,K,2)& + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,2))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 2 ! - 22 CONTINUE - IF (IA==IB .AND. IC==ID) GO TO 26 - IF (IA==ID .AND. IC==IB) GO TO 26 + 22 CONTINUE + IF (IA==IB .AND. IC==ID) GO TO 26 + IF (IA==ID .AND. IC==IB) GO TO 26 BRRA = (SKINT(RAC,IA,IC,RBD,IB,ID,K,1) + SKINT(RAC,IA,IC,RBD,IB,ID,K,2))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 3 ! - 23 CONTINUE - IF (IA == IC) THEN - DO I = 1, MXRBD - RBD(I) = RBD(I) + PF(I,ID)*QF(I,IB) - END DO + 23 CONTINUE + IF (IA == IC) THEN + DO I = 1, MXRBD + RBD(I) = RBD(I) + PF(I,ID)*QF(I,IB) + END DO BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0& ) + RKINT(RAC,IA,IC,RBD,IB,ID,K,2) + RKINT(RBD,IB,ID,RAC,IA,IC,K,2)& - )*HALF - RETURN - ENDIF - DO I = 1, MXRAC - RAC(I) = RAC(I) + PF(I,IC)*QF(I,IA) - END DO + )*HALF + RETURN + ENDIF + DO I = 1, MXRAC + RAC(I) = RAC(I) + PF(I,IC)*QF(I,IA) + END DO BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1)& + RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 4 ! - 24 CONTINUE - BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0) - RETURN + 24 CONTINUE + BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0) + RETURN ! ! ITYPE = 5 ! - 25 CONTINUE - IF (IA==ID .AND. IC==IB) GO TO 10 - 9 CONTINUE - BRRA = TWO*RKINT(RAC,IA,IC,RBD,IB,ID,K,1) - RETURN - 10 CONTINUE - BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) - RETURN + 25 CONTINUE + IF (IA==ID .AND. IC==IB) GO TO 10 + 9 CONTINUE + BRRA = TWO*RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RETURN + 10 CONTINUE + BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) + RETURN ! ! ITYPE = 6 ! - 26 CONTINUE - BRRA = SKINT(RAC,IA,IC,RBD,IB,ID,K,1) - RETURN + 26 CONTINUE + BRRA = SKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RETURN ! - END FUNCTION BRRA + END FUNCTION BRRA diff --git a/src/appl/rci90/brra_I.f90 b/src/appl/rci90/brra_I.f90 index 565cb8063..69a9efeff 100644 --- a/src/appl/rci90/brra_I.f90 +++ b/src/appl/rci90/brra_I.f90 @@ -1,15 +1,15 @@ - MODULE brra_I + MODULE brra_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION brra (ITYPE, IA, IC, IB, ID, K) - INTEGER, INTENT(IN) :: ITYPE - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION brra (ITYPE, IA, IC, IB, ID, K) + INTEGER, INTENT(IN) :: ITYPE + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/cxk.f90 b/src/appl/rci90/cxk.f90 index beb24aada..2ef0a74c0 100644 --- a/src/appl/rci90/cxk.f90 +++ b/src/appl/rci90/cxk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) + SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) ! * ! Computes the coefficients of radial integrals in the expansion * ! of the effective interaction strength: X(K,IA1,IB1,IA2,IB2). * @@ -41,241 +41,241 @@ SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cre_I + USE cre_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NU - INTEGER :: K - INTEGER, INTENT(IN) :: IBR - INTEGER, INTENT(IN) :: IEX - INTEGER, INTENT(IN) :: IS(4) - INTEGER, INTENT(IN) :: KAPS(4) - REAL(DOUBLE), INTENT(INOUT) :: S(12) + INTEGER, INTENT(IN) :: NU + INTEGER :: K + INTEGER, INTENT(IN) :: IBR + INTEGER, INTENT(IN) :: IEX + INTEGER, INTENT(IN) :: IS(4) + INTEGER, INTENT(IN) :: KAPS(4) + REAL(DOUBLE), INTENT(INOUT) :: S(12) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MU, IA, IB, IC, ID, KA, KB, KC, KD, KK, IK, IP + INTEGER :: MU, IA, IB, IC, ID, KA, KB, KC, KD, KK, IK, IP REAL(DOUBLE) :: D, H, DK1, DK2, FK, GK, G1, G2, G3, G4, A, F1, F2, F3, F4& - , B, DK + , B, DK !----------------------------------------------- ! ! ! 1.0 Initialization ! - S = 0.0D00 + S = 0.0D00 ! - IA = IS(1) - IB = IS(2) - IC = IS(3) - ID = IS(4) - KA = KAPS(1)/2 - KB = KAPS(2)/2 - KC = KAPS(3)/2 - KD = KAPS(4)/2 - IF (IEX == 2) THEN - KK = KD - IK = ID - KD = KC - ID = IC - KC = KK - IC = IK - ENDIF - SELECT CASE (IBR) - CASE DEFAULT - GO TO 17 + IA = IS(1) + IB = IS(2) + IC = IS(3) + ID = IS(4) + KA = KAPS(1)/2 + KB = KAPS(2)/2 + KC = KAPS(3)/2 + KD = KAPS(4)/2 + IF (IEX == 2) THEN + KK = KD + IK = ID + KD = KC + ID = IC + KC = KK + IC = IK + ENDIF + SELECT CASE (IBR) + CASE DEFAULT + GO TO 17 ! ! 2.0 IBR = 1 --- The general case ! - CASE (1) - IF (NU - K >= 0) THEN - IF (NU - K <= 0) THEN - S(1) = -(KA + KC)*(KD + KB) - IF (K == 0) GO TO 16 - D = K*(K + 1) - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - S(1) = S(1)*H/D - S(2:4) = S(1) - RETURN - ENDIF + CASE (1) + IF (NU - K >= 0) THEN + IF (NU - K <= 0) THEN + S(1) = -(KA + KC)*(KD + KB) + IF (K == 0) GO TO 16 + D = K*(K + 1) + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + S(1) = S(1)*H/D + S(2:4) = S(1) + RETURN + ENDIF ! ! 2.2 NU = K+1 ! - DK1 = KC - KA - DK2 = KD - KB - FK = K - GK = K + 1 - G1 = DK1 - GK - G2 = DK1 + GK - G3 = DK2 - GK - G4 = DK2 + GK - KK = K + K + 1 - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - A = H*FK/GK/DBLE(KK*(KK + 2)) - S(1) = A*G1*G3 - S(2) = A*G2*G4 - S(3) = A*G1*G4 - S(4) = A*G2*G3 - RETURN - ENDIF + DK1 = KC - KA + DK2 = KD - KB + FK = K + GK = K + 1 + G1 = DK1 - GK + G2 = DK1 + GK + G3 = DK2 - GK + G4 = DK2 + GK + KK = K + K + 1 + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + A = H*FK/GK/DBLE(KK*(KK + 2)) + S(1) = A*G1*G3 + S(2) = A*G2*G4 + S(3) = A*G1*G4 + S(4) = A*G2*G3 + RETURN + ENDIF ! ! 2.2 NU = K-1 ! - DK1 = KC - KA - DK2 = KD - KB - FK = K - GK = K + 1 - F1 = DK1 - FK - F2 = DK1 + FK - F3 = DK2 - FK - F4 = DK2 + FK - G1 = DK1 - GK - G2 = DK1 + GK - G3 = DK2 - GK - G4 = DK2 + GK - KK = K + K + 1 - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - A = H*GK/FK/DBLE(KK*(KK - 2)) - S(1) = A*F2*F4 - S(2) = A*F1*F3 - S(3) = A*F2*F3 - S(4) = A*F1*F4 - B = H/DBLE(KK*KK) - S(5) = B*F2*G3 - S(6) = B*F4*G1 - S(7) = B*F1*G4 - S(8) = B*F3*G2 - S(9) = B*F2*G4 - S(10) = B*F3*G1 - S(11) = B*F1*G3 - S(12) = B*F4*G2 - RETURN + DK1 = KC - KA + DK2 = KD - KB + FK = K + GK = K + 1 + F1 = DK1 - FK + F2 = DK1 + FK + F3 = DK2 - FK + F4 = DK2 + FK + G1 = DK1 - GK + G2 = DK1 + GK + G3 = DK2 - GK + G4 = DK2 + GK + KK = K + K + 1 + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + A = H*GK/FK/DBLE(KK*(KK - 2)) + S(1) = A*F2*F4 + S(2) = A*F1*F3 + S(3) = A*F2*F3 + S(4) = A*F1*F4 + B = H/DBLE(KK*KK) + S(5) = B*F2*G3 + S(6) = B*F4*G1 + S(7) = B*F1*G4 + S(8) = B*F3*G2 + S(9) = B*F2*G4 + S(10) = B*F3*G1 + S(11) = B*F1*G3 + S(12) = B*F4*G2 + RETURN ! ! 3.0 IBR = 2 Degenerate case: only one non-zero R-integral ! - CASE (2) - IF (IA/=IC .OR. IB==ID) THEN - IF (IA==IC .OR. IB/=ID) GO TO 17 + CASE (2) + IF (IA/=IC .OR. IB==ID) THEN + IF (IA==IC .OR. IB/=ID) GO TO 17 ! - IK = IB - IB = IA - IA = IK - IK = ID - ID = IC - IC = IK + IK = IB + IB = IA + IA = IK + IK = ID + ID = IC + IC = IK ! - KK = KB - KB = KA - KA = KK - KK = KD - KD = KC - KC = KK - ENDIF + KK = KB + KB = KA + KA = KK + KK = KD + KD = KC + KC = KK + ENDIF ! - IF (MOD(K,2) /= 1) RETURN - DK = K*(K + 1) - H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK - S(1) = H*DBLE(4*KA*(KB + KD)) - RETURN + IF (MOD(K,2) /= 1) RETURN + DK = K*(K + 1) + H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK + S(1) = H*DBLE(4*KA*(KB + KD)) + RETURN ! ! 4.0 IBR = 3. Direct magnetic F-integrals ! - CASE (3) - IF (IA/=IC .OR. IB/=ID) GO TO 17 - IF (MOD(K,2) /= 1) RETURN - DK = K*(K + 1) - H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK - S(1) = H*DBLE(16*KA*KB) - RETURN + CASE (3) + IF (IA/=IC .OR. IB/=ID) GO TO 17 + IF (MOD(K,2) /= 1) RETURN + DK = K*(K + 1) + H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK + S(1) = H*DBLE(16*KA*KB) + RETURN ! ! 5.0 IBR = 4. Exchange magnetic G- and H-integrals ! - CASE (4) - IF (IA/=ID .OR. IB/=IC) GO TO 17 - IF (NU - K >= 0) THEN - IF (NU - K <= 0) THEN - S(1) = DBLE(KA + KB)*CRE(KA,K,KB) - IP = ABS(KA) - ABS(KB) + K + 1 - S(1) = S(1)*S(1)/DBLE(K*(K + 1)) - IF (MOD(IP,2) /= 0) S(1) = -S(1) - S(3) = S(1) - S(2) = S(1) + S(1) - RETURN - ENDIF + CASE (4) + IF (IA/=ID .OR. IB/=IC) GO TO 17 + IF (NU - K >= 0) THEN + IF (NU - K <= 0) THEN + S(1) = DBLE(KA + KB)*CRE(KA,K,KB) + IP = ABS(KA) - ABS(KB) + K + 1 + S(1) = S(1)*S(1)/DBLE(K*(K + 1)) + IF (MOD(IP,2) /= 0) S(1) = -S(1) + S(3) = S(1) + S(2) = S(1) + S(1) + RETURN + ENDIF ! ! 5.2 NU = K+1 ! - DK = KB - KA - GK = K + 1 - FK = K - G1 = DK + GK - G2 = DK - GK - KK = K + K + 1 - H = CRE(KA,K,KB)**2 - IF (KA*KB < 0) H = -H - A = H*FK/GK/DBLE(KK*(KK + 2)) - S(1) = -A*G1*G1 - S(2) = -2.0D00*A*G1*G2 - S(3) = -A*G2*G2 - RETURN - ENDIF + DK = KB - KA + GK = K + 1 + FK = K + G1 = DK + GK + G2 = DK - GK + KK = K + K + 1 + H = CRE(KA,K,KB)**2 + IF (KA*KB < 0) H = -H + A = H*FK/GK/DBLE(KK*(KK + 2)) + S(1) = -A*G1*G1 + S(2) = -2.0D00*A*G1*G2 + S(3) = -A*G2*G2 + RETURN + ENDIF ! ! 5.3 NU = K-1 ! - DK = KB - KA - FK = K - GK = K + 1 - F1 = DK + FK - F2 = DK - FK - G1 = DK + GK - G2 = DK - GK - KK = K + K + 1 - H = CRE(KA,K,KB)**2 - IF (KA*KB < 0) H = -H - A = H*GK/FK/DBLE(KK*(KK - 2)) - S(1) = -A*F2*F2 - S(2) = -2.0D00*A*F1*F2 - S(3) = -A*F1*F1 - B = H/DBLE(KK*KK) - B = B + B - S(4) = -B*F1*G2 + DK = KB - KA + FK = K + GK = K + 1 + F1 = DK + FK + F2 = DK - FK + G1 = DK + GK + G2 = DK - GK + KK = K + K + 1 + H = CRE(KA,K,KB)**2 + IF (KA*KB < 0) H = -H + A = H*GK/FK/DBLE(KK*(KK - 2)) + S(1) = -A*F2*F2 + S(2) = -2.0D00*A*F1*F2 + S(3) = -A*F1*F1 + B = H/DBLE(KK*KK) + B = B + B + S(4) = -B*F1*G2 ! S(5) = S(4) - S(5) = -B*F2*G1 - S(6) = -B*F1*G1 - S(7) = -B*F2*G2 - RETURN - END SELECT + S(5) = -B*F2*G1 + S(6) = -B*F1*G1 + S(7) = -B*F2*G2 + RETURN + END SELECT ! ! 6.0 Special cases and errors ! ! Illegal zero value of K in Type 1 ! - 16 CONTINUE - WRITE (*, 300) IS(1), IS(2), IS(3), IS(4), NU, IBR, IEX - STOP + 16 CONTINUE + WRITE (*, 300) IS(1), IS(2), IS(3), IS(4), NU, IBR, IEX + STOP ! ! Illegal combination of states in Type 3 or 4 ! - 17 CONTINUE - WRITE (*, 301) IBR, IS(1), IS(2), IS(3), IS(4), NU, K, IEX - STOP + 17 CONTINUE + WRITE (*, 301) IBR, IS(1), IS(2), IS(3), IS(4), NU, K, IEX + STOP ! - 300 FORMAT('CXK: Illegal value K = 0 -'/,1X,4I3,2X,I3,2X,2I2) - 301 FORMAT('CXK: Type ',I2,'-'/,1X,I2,3X,4I3,2X,2I3,2X,I2) - RETURN + 300 FORMAT('CXK: Illegal value K = 0 -'/,1X,4I3,2X,I3,2X,2I2) + 301 FORMAT('CXK: Type ',I2,'-'/,1X,I2,3X,4I3,2X,2I3,2X,I2) + RETURN ! - END SUBROUTINE CXK + END SUBROUTINE CXK diff --git a/src/appl/rci90/cxk_I.f90 b/src/appl/rci90/cxk_I.f90 index be29bee47..a56786814 100644 --- a/src/appl/rci90/cxk_I.f90 +++ b/src/appl/rci90/cxk_I.f90 @@ -1,17 +1,17 @@ - MODULE cxk_I + MODULE cxk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IBR - INTEGER, INTENT(IN) :: IEX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IBR + INTEGER, INTENT(IN) :: IEX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/dmerge_dnicmv_I.f90 b/src/appl/rci90/dmerge_dnicmv_I.f90 index 30f11d601..e65dac396 100644 --- a/src/appl/rci90/dmerge_dnicmv_I.f90 +++ b/src/appl/rci90/dmerge_dnicmv_I.f90 @@ -1,16 +1,16 @@ - MODULE dmerge_dnicmv_I + MODULE dmerge_dnicmv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dmerge_dnicmv (N, DB, DC, DA, DCONST, DL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC - REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA - REAL(DOUBLE), INTENT(IN) :: DCONST - REAL(DOUBLE), INTENT(OUT) :: DL - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dmerge_dnicmv (N, DB, DC, DA, DCONST, DL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC + REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA + REAL(DOUBLE), INTENT(IN) :: DCONST + REAL(DOUBLE), INTENT(OUT) :: DL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/dnicmv.f90 b/src/appl/rci90/dnicmv.f90 index 3b8480e9c..c5813cc3c 100644 --- a/src/appl/rci90/dnicmv.f90 +++ b/src/appl/rci90/dnicmv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DNICMV(N, M, B, C) + SUBROUTINE DNICMV(N, M, B, C) ! * ! Matrix-matrix product: C = AB. The lower triangle of the (NxN) * ! matrix is assumed available in packed form in the array EMT. The * @@ -16,96 +16,96 @@ SUBROUTINE DNICMV(N, M, B, C) ! Block version by Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE hmat_C, ONLY: EMT !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dinit_I -! USE dmerge_dnicmv_I + USE dinit_I +! USE dmerge_dnicmv_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M REAL(DOUBLE), DIMENSION(N,M) :: B REAL(DOUBLE), DIMENSION(N,M) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MYID, NPROCS, IBEG, IEND, ICOL, NELC, IV - REAL(DOUBLE) :: DIAG, DL + INTEGER :: MYID, NPROCS, IBEG, IEND, ICOL, NELC, IV + REAL(DOUBLE) :: DIAG, DL !----------------------------------------------- - MYID = 0 - NPROCS = 1 - + MYID = 0 + NPROCS = 1 + ! Initialise the result matrix; note that this is specific to the ! data structure of DVDSON --- there is no overdimensioning - - CALL DINIT (N*M, 0.0D00, C, 1) - - IBEG = 1 - IEND = 0 - DO ICOL = MYID + 1, N, NPROCS - IEND = IEND + ICOL - NELC = IEND - IBEG + 1 - DO IV = 1, M - DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) - CALL DMERGE_DNICMV (NELC - 1, B(1:N,IV), C(1:N,IV), & - EMT(IBEG:IEND), B(ICOL,IV), DL) - C(ICOL,IV) = DIAG + DL - END DO - IBEG = IEND + 1 - END DO - - RETURN - END SUBROUTINE DNICMV + + CALL DINIT (N*M, 0.0D00, C, 1) + + IBEG = 1 + IEND = 0 + DO ICOL = MYID + 1, N, NPROCS + IEND = IEND + ICOL + NELC = IEND - IBEG + 1 + DO IV = 1, M + DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) + CALL DMERGE_DNICMV (NELC - 1, B(1:N,IV), C(1:N,IV), & + EMT(IBEG:IEND), B(ICOL,IV), DL) + C(ICOL,IV) = DIAG + DL + END DO + IBEG = IEND + 1 + END DO + + RETURN + END SUBROUTINE DNICMV + - !*********************************************************************** ! * - SUBROUTINE DMERGE_DNICMV(N, DB, DC, DA, DCONST, DL) + SUBROUTINE DMERGE_DNICMV(N, DB, DC, DA, DCONST, DL) ! ! Used by dnimcv ! Developed from dmerge. The only diff is: idy not needed here ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/057 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: DCONST - REAL(DOUBLE), INTENT(OUT) :: DL + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: DCONST + REAL(DOUBLE), INTENT(OUT) :: DL REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DSUM -!----------------------------------------------- - - DSUM = 0.D0 - DSUM = DOT_PRODUCT(DA,DB(:N)) - DC(:N) = DC(:N) + DCONST*DA - DL = DSUM - - RETURN - END SUBROUTINE DMERGE_DNICMV + INTEGER :: I + REAL(DOUBLE) :: DSUM +!----------------------------------------------- + + DSUM = 0.D0 + DSUM = DOT_PRODUCT(DA,DB(:N)) + DC(:N) = DC(:N) + DCONST*DA + DL = DSUM + + RETURN + END SUBROUTINE DMERGE_DNICMV diff --git a/src/appl/rci90/dnicmv_I.f90 b/src/appl/rci90/dnicmv_I.f90 index c01e07782..d9fd62f4e 100644 --- a/src/appl/rci90/dnicmv_I.f90 +++ b/src/appl/rci90/dnicmv_I.f90 @@ -1,14 +1,14 @@ - MODULE dnicmv_I + MODULE dnicmv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dnicmv (N, M, B, C) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dnicmv (N, M, B, C) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/dspevx.f90 b/src/appl/rci90/dspevx.f90 index 270bd6b29..bd39c115a 100644 --- a/src/appl/rci90/dspevx.f90 +++ b/src/appl/rci90/dspevx.f90 @@ -1,50 +1,50 @@ !*********************************************************************** ! * - + SUBROUTINE DSPEVX(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W& - , Z, LDZ, WORK, IWORK, IFAIL, INFO) + , Z, LDZ, WORK, IWORK, IFAIL, INFO) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE cons_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lsame_I - USE dlamch_I - USE dlansp_I - USE dcopy_I - USE dopgtr_I - USE dopmtr_I - USE dscal_I - USE dsptrd_I - USE dstebz_I - USE dstein_I - USE dsteqr_I - USE dsterf_I - USE dswap_I - USE xerbla_I + USE lsame_I + USE dlamch_I + USE dlansp_I + USE dcopy_I + USE dopgtr_I + USE dopmtr_I + USE dscal_I + USE dsptrd_I + USE dstebz_I + USE dstein_I + USE dsteqr_I + USE dsterf_I + USE dswap_I + USE xerbla_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: IL - INTEGER :: IU - INTEGER :: M - INTEGER :: LDZ - INTEGER :: INFO - REAL(DOUBLE), INTENT(IN) :: VL - REAL(DOUBLE), INTENT(IN) :: VU - REAL(DOUBLE), INTENT(IN) :: ABSTOL - CHARACTER :: JOBZ - CHARACTER :: RANGE - CHARACTER :: UPLO + INTEGER :: N + INTEGER :: IL + INTEGER :: IU + INTEGER :: M + INTEGER :: LDZ + INTEGER :: INFO + REAL(DOUBLE), INTENT(IN) :: VL + REAL(DOUBLE), INTENT(IN) :: VU + REAL(DOUBLE), INTENT(IN) :: ABSTOL + CHARACTER :: JOBZ + CHARACTER :: RANGE + CHARACTER :: UPLO INTEGER, DIMENSION(*) :: IWORK INTEGER, DIMENSION(*) :: IFAIL REAL(DOUBLE), DIMENSION(*) :: AP @@ -55,15 +55,15 @@ SUBROUTINE DSPEVX(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W& ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, INDISP, INDIWO, & - INDTAU, INDWRK, ISCALE, ITMP1, J, JJ, NSPLIT + INDTAU, INDWRK, ISCALE, ITMP1, J, JJ, NSPLIT REAL(DOUBLE) :: ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, & - SMLNUM, TMP1, VLL, VUU - LOGICAL :: ALLEIG, INDEIG, VALEIG, WANTZ - CHARACTER :: ORDER + SMLNUM, TMP1, VLL, VUU + LOGICAL :: ALLEIG, INDEIG, VALEIG, WANTZ + CHARACTER :: ORDER !----------------------------------------------- ! I n t r i n s i c F u n c t i o n s !----------------------------------------------- - INTRINSIC MIN, SQRT + INTRINSIC MIN, SQRT !----------------------------------------------- ! ! -- LAPACK driver routine (version 2.0) -- @@ -210,188 +210,188 @@ SUBROUTINE DSPEVX(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W& ! ! Test the input parameters. ! - WANTZ = LSAME(JOBZ,'V') - ALLEIG = LSAME(RANGE,'A') - VALEIG = LSAME(RANGE,'V') - INDEIG = LSAME(RANGE,'I') -! - INFO = 0 - IF (.NOT.(WANTZ .OR. LSAME(JOBZ,'N'))) THEN - INFO = -1 - ELSE IF (.NOT.(ALLEIG .OR. VALEIG .OR. INDEIG)) THEN - INFO = -2 - ELSE IF (.NOT.(LSAME(UPLO,'L') .OR. LSAME(UPLO,'U'))) THEN - INFO = -3 - ELSE IF (N < 0) THEN - INFO = -4 - ELSE IF (VALEIG .AND. N>0 .AND. VU<=VL) THEN - INFO = -7 - ELSE IF (INDEIG .AND. IL<1) THEN - INFO = -8 - ELSE IF (INDEIG .AND. (IUN)) THEN - INFO = -9 - ELSE IF (LDZ<1 .OR. WANTZ .AND. LDZ0 .AND. VU<=VL) THEN + INFO = -7 + ELSE IF (INDEIG .AND. IL<1) THEN + INFO = -8 + ELSE IF (INDEIG .AND. (IUN)) THEN + INFO = -9 + ELSE IF (LDZ<1 .OR. WANTZ .AND. LDZ=AP(1)) THEN - M = 1 - W(1) = AP(1) - ENDIF - ENDIF - IF (WANTZ) Z(1,1) = ONE - RETURN - ENDIF + M = 0 + IF (N == 0) RETURN +! + IF (N == 1) THEN + IF (ALLEIG .OR. INDEIG) THEN + M = 1 + W(1) = AP(1) + ELSE + IF (VL=AP(1)) THEN + M = 1 + W(1) = AP(1) + ENDIF + ENDIF + IF (WANTZ) Z(1,1) = ONE + RETURN + ENDIF ! ! Get machine constants. ! - SAFMIN = DLAMCH('Safe minimum') - EPS = DLAMCH('Precision') - SMLNUM = SAFMIN/EPS - BIGNUM = ONE/SMLNUM - RMIN = SQRT(SMLNUM) - RMAX = MIN(SQRT(BIGNUM),ONE/SQRT(SQRT(SAFMIN))) + SAFMIN = DLAMCH('Safe minimum') + EPS = DLAMCH('Precision') + SMLNUM = SAFMIN/EPS + BIGNUM = ONE/SMLNUM + RMIN = SQRT(SMLNUM) + RMAX = MIN(SQRT(BIGNUM),ONE/SQRT(SQRT(SAFMIN))) ! ! Scale matrix to allowable range, if necessary. ! - ISCALE = 0 - ABSTLL = ABSTOL - IF (VALEIG) THEN - VLL = VL - VUU = VU - ENDIF - ANRM = DLANSP('M',UPLO,N,AP,WORK) - IF (ANRM>ZERO .AND. ANRM RMAX) THEN - ISCALE = 1 - SIGMA = RMAX/ANRM - ENDIF - IF (ISCALE == 1) THEN - CALL DSCAL ((N*(N + 1))/2, SIGMA, AP, 1) - IF (ABSTOL > 0) ABSTLL = ABSTOL*SIGMA - IF (VALEIG) THEN - VLL = VL*SIGMA - VUU = VU*SIGMA - ENDIF - ENDIF + ISCALE = 0 + ABSTLL = ABSTOL + IF (VALEIG) THEN + VLL = VL + VUU = VU + ENDIF + ANRM = DLANSP('M',UPLO,N,AP,WORK) + IF (ANRM>ZERO .AND. ANRM RMAX) THEN + ISCALE = 1 + SIGMA = RMAX/ANRM + ENDIF + IF (ISCALE == 1) THEN + CALL DSCAL ((N*(N + 1))/2, SIGMA, AP, 1) + IF (ABSTOL > 0) ABSTLL = ABSTOL*SIGMA + IF (VALEIG) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + ENDIF + ENDIF ! ! Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. ! - INDTAU = 1 - INDE = INDTAU + N - INDD = INDE + N - INDWRK = INDD + N - CALL DSPTRD (UPLO, N, AP, WORK(INDD), WORK(INDE), WORK(INDTAU), IINFO) + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDWRK = INDD + N + CALL DSPTRD (UPLO, N, AP, WORK(INDD), WORK(INDE), WORK(INDTAU), IINFO) ! ! If all eigenvalues are desired and ABSTOL is less than or equal ! to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails ! for some eigenvalue, then try DSTEBZ. ! - IF ((ALLEIG .OR. INDEIG .AND. IL==1 .AND. IU==N) .AND. ABSTOL<=ZERO) THEN - CALL DCOPY (N, WORK(INDD), 1, W, 1) - INDEE = INDWRK + 2*N - IF (.NOT.WANTZ) THEN - CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1) - CALL DSTERF (N, W, WORK(INDEE), INFO) - ELSE + IF ((ALLEIG .OR. INDEIG .AND. IL==1 .AND. IU==N) .AND. ABSTOL<=ZERO) THEN + CALL DCOPY (N, WORK(INDD), 1, W, 1) + INDEE = INDWRK + 2*N + IF (.NOT.WANTZ) THEN + CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1) + CALL DSTERF (N, W, WORK(INDEE), INFO) + ELSE CALL DOPGTR (UPLO, N, AP, WORK(INDTAU), Z, LDZ, WORK(INDWRK), IINFO& - ) - CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1) - CALL DSTEQR (JOBZ, N, W, WORK(INDEE), Z, LDZ, WORK(INDWRK), INFO) - IF (INFO == 0) THEN - IFAIL(:N) = 0 - ENDIF - ENDIF - IF (INFO == 0) THEN - M = N - GO TO 20 - ENDIF - INFO = 0 - ENDIF + ) + CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1) + CALL DSTEQR (JOBZ, N, W, WORK(INDEE), Z, LDZ, WORK(INDWRK), INFO) + IF (INFO == 0) THEN + IFAIL(:N) = 0 + ENDIF + ENDIF + IF (INFO == 0) THEN + M = N + GO TO 20 + ENDIF + INFO = 0 + ENDIF ! ! Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. ! - IF (WANTZ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - ENDIF - INDIBL = 1 - INDISP = INDIBL + N - INDIWO = INDISP + N + IF (WANTZ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + ENDIF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N CALL DSTEBZ (RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, WORK(INDD), WORK(& INDE), M, NSPLIT, W, IWORK(INDIBL), IWORK(INDISP), WORK(INDWRK), IWORK& - (INDIWO), INFO) + (INDIWO), INFO) ! - IF (WANTZ) THEN + IF (WANTZ) THEN CALL DSTEIN (N, WORK(INDD), WORK(INDE), M, W, IWORK(INDIBL), IWORK(& - INDISP), Z, LDZ, WORK(INDWRK), IWORK(INDIWO), IFAIL, INFO) + INDISP), Z, LDZ, WORK(INDWRK), IWORK(INDIWO), IFAIL, INFO) ! ! Apply orthogonal matrix used in reduction to tridiagonal ! form to eigenvectors returned by DSTEIN. ! CALL DOPMTR ('L', UPLO, 'N', N, M, AP, WORK(INDTAU), Z, LDZ, WORK(& - INDWRK), INFO) - ENDIF + INDWRK), INFO) + ENDIF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! - 20 CONTINUE - IF (ISCALE == 1) THEN - IF (INFO == 0) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - ENDIF - CALL DSCAL (IMAX, ONE/SIGMA, W, 1) - ENDIF + 20 CONTINUE + IF (ISCALE == 1) THEN + IF (INFO == 0) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + ENDIF + CALL DSCAL (IMAX, ONE/SIGMA, W, 1) + ENDIF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! - IF (WANTZ) THEN - DO J = 1, M - 1 - I = 0 - TMP1 = W(J) - DO JJ = J + 1, M - IF (W(JJ) >= TMP1) CYCLE - I = JJ - TMP1 = W(JJ) - END DO -! - IF (I == 0) CYCLE - ITMP1 = IWORK(INDIBL+I-1) - W(I) = W(J) - IWORK(INDIBL+I-1) = IWORK(INDIBL+J-1) - W(J) = TMP1 - IWORK(INDIBL+J-1) = ITMP1 - CALL DSWAP (N, Z(1,I), 1, Z(1,J), 1) - IF (INFO == 0) CYCLE - ITMP1 = IFAIL(I) - IFAIL(I) = IFAIL(J) - IFAIL(J) = ITMP1 - END DO - ENDIF -! - RETURN + IF (WANTZ) THEN + DO J = 1, M - 1 + I = 0 + TMP1 = W(J) + DO JJ = J + 1, M + IF (W(JJ) >= TMP1) CYCLE + I = JJ + TMP1 = W(JJ) + END DO +! + IF (I == 0) CYCLE + ITMP1 = IWORK(INDIBL+I-1) + W(I) = W(J) + IWORK(INDIBL+I-1) = IWORK(INDIBL+J-1) + W(J) = TMP1 + IWORK(INDIBL+J-1) = ITMP1 + CALL DSWAP (N, Z(1,I), 1, Z(1,J), 1) + IF (INFO == 0) CYCLE + ITMP1 = IFAIL(I) + IFAIL(I) = IFAIL(J) + IFAIL(J) = ITMP1 + END DO + ENDIF +! + RETURN ! ! End of DSPEVX ! - END SUBROUTINE DSPEVX + END SUBROUTINE DSPEVX diff --git a/src/appl/rci90/dspevx_I.f90 b/src/appl/rci90/dspevx_I.f90 index 679958024..7c09067c5 100644 --- a/src/appl/rci90/dspevx_I.f90 +++ b/src/appl/rci90/dspevx_I.f90 @@ -1,29 +1,29 @@ - MODULE dspevx_I + MODULE dspevx_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE dspevx (JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W& - , Z, LDZ, WORK, IWORK, IFAIL, INFO) - USE vast_kind_param,ONLY: DOUBLE - CHARACTER (LEN = 1) :: JOBZ - CHARACTER (LEN = 1) :: RANGE - CHARACTER (LEN = 1) :: UPLO - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: AP - REAL(DOUBLE), INTENT(IN) :: VL - REAL(DOUBLE), INTENT(IN) :: VU - INTEGER, INTENT(IN) :: IL - INTEGER, INTENT(IN) :: IU - REAL(DOUBLE), INTENT(IN) :: ABSTOL - INTEGER, INTENT(OUT) :: M - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: W - REAL(DOUBLE), DIMENSION(LDZ,*), INTENT(OUT) :: Z - INTEGER, INTENT(IN) :: LDZ - REAL(DOUBLE), DIMENSION(*) :: WORK - INTEGER, DIMENSION(*), INTENT(INOUT) :: IWORK - INTEGER, DIMENSION(*), INTENT(INOUT) :: IFAIL - INTEGER, INTENT(OUT) :: INFO - END SUBROUTINE - END INTERFACE - END MODULE + , Z, LDZ, WORK, IWORK, IFAIL, INFO) + USE vast_kind_param,ONLY: DOUBLE + CHARACTER (LEN = 1) :: JOBZ + CHARACTER (LEN = 1) :: RANGE + CHARACTER (LEN = 1) :: UPLO + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: AP + REAL(DOUBLE), INTENT(IN) :: VL + REAL(DOUBLE), INTENT(IN) :: VU + INTEGER, INTENT(IN) :: IL + INTEGER, INTENT(IN) :: IU + REAL(DOUBLE), INTENT(IN) :: ABSTOL + INTEGER, INTENT(OUT) :: M + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: W + REAL(DOUBLE), DIMENSION(LDZ,*), INTENT(OUT) :: Z + INTEGER, INTENT(IN) :: LDZ + REAL(DOUBLE), DIMENSION(*) :: WORK + INTEGER, DIMENSION(*), INTENT(INOUT) :: IWORK + INTEGER, DIMENSION(*), INTENT(INOUT) :: IFAIL + INTEGER, INTENT(OUT) :: INFO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/engout.f90 b/src/appl/rci90/engout.f90 index 6271a85fe..ab4e1c2f6 100644 --- a/src/appl/rci90/engout.f90 +++ b/src/appl/rci90/engout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) + SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,87 +13,87 @@ SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE jlabl_C, labj=>jlbr, labp=>jlbp IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JTOT - INTEGER, INTENT(IN) :: IPAR - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - REAL(DOUBLE), INTENT(IN) :: EAV + INTEGER, INTENT(IN) :: JTOT + INTEGER, INTENT(IN) :: IPAR + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + REAL(DOUBLE), INTENT(IN) :: EAV INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO + WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,2X,2A4,1P,3D22.14) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,2X,2A4,1P,3D22.14) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUT + END SUBROUTINE ENGOUT diff --git a/src/appl/rci90/engout_I.f90 b/src/appl/rci90/engout_I.f90 index df0bdbe27..47d7a0bcc 100644 --- a/src/appl/rci90/engout_I.f90 +++ b/src/appl/rci90/engout_I.f90 @@ -1,17 +1,17 @@ - MODULE engout_I + MODULE engout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, INTENT(IN) :: JTOT - INTEGER, INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, INTENT(IN) :: JTOT + INTEGER, INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/evcout.f90 b/src/appl/rci90/evcout.f90 index 1d08e9535..459b7cdc1 100644 --- a/src/appl/rci90/evcout.f90 +++ b/src/appl/rci90/evcout.f90 @@ -9,8 +9,8 @@ SUBROUTINE EVCOUT ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -18,7 +18,7 @@ SUBROUTINE EVCOUT USE vast_kind_param, ONLY: DOUBLE USE memory_man USE eigv_C - USE orb_C, ONLY: ncf, nw, iqa + USE orb_C, ONLY: ncf, nw, iqa USE prnt_C IMPLICIT NONE !----------------------------------------------- diff --git a/src/appl/rci90/funk.f90 b/src/appl/rci90/funk.f90 index 538a948c7..bf02cb0e6 100644 --- a/src/appl/rci90/funk.f90 +++ b/src/appl/rci90/funk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) + REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) ! * ! This function evaluates the KN(X) functions using the analytic * ! functions defined in tables 1 and 3 of Fullerton and Rinker. * @@ -8,29 +8,29 @@ REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!... Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!... Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - REAL(DOUBLE) , INTENT(IN) :: X + INTEGER, INTENT(IN) :: N + REAL(DOUBLE) , INTENT(IN) :: X !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(4) :: NP - INTEGER :: K, NN, I - REAL(DOUBLE), DIMENSION(10,4) :: P - REAL(DOUBLE), DIMENSION(2,4) :: B - REAL(DOUBLE), DIMENSION(3,4) :: C - REAL(DOUBLE), DIMENSION(5,4) :: D, E - REAL(DOUBLE) :: XN, SUM, X2, BSUM, CSUM, DSUM, ESUM, XM + INTEGER, DIMENSION(4) :: NP + INTEGER :: K, NN, I + REAL(DOUBLE), DIMENSION(10,4) :: P + REAL(DOUBLE), DIMENSION(2,4) :: B + REAL(DOUBLE), DIMENSION(3,4) :: C + REAL(DOUBLE), DIMENSION(5,4) :: D, E + REAL(DOUBLE) :: XN, SUM, X2, BSUM, CSUM, DSUM, ESUM, XM !----------------------------------------------- ! ! @@ -45,104 +45,104 @@ REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) -2.3969236620D-04, 0.0D00, 6.0000000002D00, -6.4305200000D-08, & 2.1049413000D-06, -2.6711271500D-05, -1.3705236152D-01, & -6.3476104090D-04, -7.8739801501D-02, -1.9641740173D-03, & - -3.4752369349D-03, - 7.3145316220D-04/ + -3.4752369349D-03, - 7.3145316220D-04/ ! DATA B/ -3.19999594323D+02, 2.53900995981D00, -6.40514843293D+01, & 7.11722714285D-01, 5.19010136460D+03, 8.28495496200D+01, & - 3.18150793824D+02, 4.33898867347D+01/ + 3.18150793824D+02, 4.33898867347D+01/ ! DATA C/ -3.19999594333D+02, 2.53901020662D+00, 0.0D00, 6.40514843287D+01& , -7.11722686403D-01, 8.042207748D-04, 2.76805406060D+04, & -3.27039477790D+02, 0.0D00, 8.48402116837D+02, -2.56939867765D+01, & - 3.20844906346D-01/ + 3.20844906346D-01/ ! DATA D/ 5.018065179D+00, 7.151891262D+01, 2.116209929D+02, & 3.140327478D+01, -1.0D00, 2.172386409D+02, 1.643364528D+03, & 2.122244512D+03, -4.512004044D+01, 1.0D00, 8.540770444D00, & 6.076242766D+01, 9.714630584D+01, 3.154973593D+01, 1.0D00, & 5.9243015865D-01, 2.0596312871D00, 3.7785190424D00, 3.5614853214D00, & - 1.0D00/ + 1.0D00/ ! DATA E/ 2.669207401D+00, 5.172549669D+01, 2.969809720D+02, & 5.364324164D+02, 1.535335924D+02, 1.155589983D+02, 1.292191441D+03, & 3.831198012D+03, 2.904410075D+03, 0.0D00, 4.543392478D00, & 3.514920169D+01, 6.019668656D+01, 8.468839579D00, 0.0D00, & 3.1511867816D-01, 3.473245222D-01, 3.8791936870D-02, -1.3059741497D-03& - , 0.0D00/ -! - DATA NP/ 8, 8, 9, 10/ -! - IF (X /= 0.0D00) THEN - IF (N<0 .OR. N==2 .OR. N==4 .OR. N>5) GO TO 98 - IF (N - 3 <= 0) THEN - IF (N - 3 /= 0) THEN - K = N + 1 - XN = 1.0D00 - GO TO 4 - ENDIF - K = N - XN = 1.0D00/X**2 - GO TO 4 - ENDIF - K = N - 1 - XN = 1.0D00/X**4 - 4 CONTINUE - IF (X <= 1.0D00) THEN + , 0.0D00/ +! + DATA NP/ 8, 8, 9, 10/ +! + IF (X /= 0.0D00) THEN + IF (N<0 .OR. N==2 .OR. N==4 .OR. N>5) GO TO 98 + IF (N - 3 <= 0) THEN + IF (N - 3 /= 0) THEN + K = N + 1 + XN = 1.0D00 + GO TO 4 + ENDIF + K = N + XN = 1.0D00/X**2 + GO TO 4 + ENDIF + K = N - 1 + XN = 1.0D00/X**4 + 4 CONTINUE + IF (X <= 1.0D00) THEN ! ! Calculate function for X < = 1 ! - NN = NP(K) - SUM = 0.0D00 - DO I = 1, NN - SUM = SUM + P(I,K)*XN - XN = XN*X - END DO - X2 = X*X - BSUM = B(1,K) + X2*(B(2,K)+X2) - CSUM = C(1,K) + X2*(C(2,K)+X2*C(3,K)) - GO TO (6,8,7,8) K - 6 CONTINUE - BSUM = BSUM*X - GO TO 8 - 7 CONTINUE - BSUM = BSUM*X2 - 8 CONTINUE - SUM = SUM + BSUM*LOG(X)/CSUM - FUNK = SUM - RETURN - ENDIF + NN = NP(K) + SUM = 0.0D00 + DO I = 1, NN + SUM = SUM + P(I,K)*XN + XN = XN*X + END DO + X2 = X*X + BSUM = B(1,K) + X2*(B(2,K)+X2) + CSUM = C(1,K) + X2*(C(2,K)+X2*C(3,K)) + GO TO (6,8,7,8) K + 6 CONTINUE + BSUM = BSUM*X + GO TO 8 + 7 CONTINUE + BSUM = BSUM*X2 + 8 CONTINUE + SUM = SUM + BSUM*LOG(X)/CSUM + FUNK = SUM + RETURN + ENDIF ! ! Calculate function for X > 1 ! - XN = 1.0D00 - DSUM = 0.0D00 - ESUM = 0.0D00 - DO I = 1, 5 - DSUM = DSUM + D(I,K)*XN - ESUM = ESUM + E(I,K)*XN - XN = XN/X - END DO - XM = -X - SUM = DSUM*EXP(XM)/(ESUM*SQRT(X**3)) - FUNK = SUM - RETURN - ENDIF - IF (N /= 0) GO TO 99 - FUNK = P(1,1) - RETURN + XN = 1.0D00 + DSUM = 0.0D00 + ESUM = 0.0D00 + DO I = 1, 5 + DSUM = DSUM + D(I,K)*XN + ESUM = ESUM + E(I,K)*XN + XN = XN/X + END DO + XM = -X + SUM = DSUM*EXP(XM)/(ESUM*SQRT(X**3)) + FUNK = SUM + RETURN + ENDIF + IF (N /= 0) GO TO 99 + FUNK = P(1,1) + RETURN ! ! Error section ! - 98 CONTINUE - WRITE (*, 302) - STOP - 99 CONTINUE - WRITE (*, 301) - STOP + 98 CONTINUE + WRITE (*, 302) + STOP + 99 CONTINUE + WRITE (*, 301) + STOP ! - 301 FORMAT(/,' Attempt to calculate FUNK (0,N) for N > 0') + 301 FORMAT(/,' Attempt to calculate FUNK (0,N) for N > 0') 302 FORMAT(/,' Attempt to calculate FUNK (X,N) for N other than',& - ' 0, 1, 3 and 5.') - RETURN + ' 0, 1, 3 and 5.') + RETURN ! - END FUNCTION FUNK + END FUNCTION FUNK diff --git a/src/appl/rci90/funk_I.f90 b/src/appl/rci90/funk_I.f90 index 9b8772bb4..bf3cb2774 100644 --- a/src/appl/rci90/funk_I.f90 +++ b/src/appl/rci90/funk_I.f90 @@ -1,13 +1,13 @@ - MODULE funk_I + MODULE funk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!... Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!... Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION funk (X, N) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: X - INTEGER, INTENT(IN) :: N + REAL(KIND(0.0D0)) FUNCTION funk (X, N) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: N !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/funl.f90 b/src/appl/rci90/funl.f90 index 6b9b226bc..06abde76b 100644 --- a/src/appl/rci90/funl.f90 +++ b/src/appl/rci90/funl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) + REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) ! * ! This function evaluates the LK(X) functions using the analytic * ! functions defined in table 5 and equations (20) and (21) of * @@ -10,92 +10,92 @@ REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(IN) :: X !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K1, I - REAL(DOUBLE), DIMENSION(6,2) :: F - REAL(DOUBLE), DIMENSION(3,2) :: G - REAL(DOUBLE), DIMENSION(2,2) :: H - REAL(DOUBLE) :: A, B, SUM, XN, X2, SUMG, SUMH, XM + INTEGER :: K1, I + REAL(DOUBLE), DIMENSION(6,2) :: F + REAL(DOUBLE), DIMENSION(3,2) :: G + REAL(DOUBLE), DIMENSION(2,2) :: H + REAL(DOUBLE) :: A, B, SUM, XN, X2, SUMG, SUMH, XM !----------------------------------------------- ! ! DATA F/ 2.008188D00, -2.397605D00, 1.046471D00, -3.670660D-01, & 6.374000D-02, -3.705800D-02, 1.646407D00, -2.092942D00, 9.623100D-01, & - -2.549600D-01, 1.644040D-01, 0.0D00/ + -2.549600D-01, 1.644040D-01, 0.0D00/ ! DATA G/ 7.51198D-01, 1.38889D-01, 2.0886D-02, 1.37691D-01, -4.16667D-01, & - - 9.7486D-02/ + - 9.7486D-02/ ! - DATA H/ -4.44444D-01, -3.472D-03, 4.44444D-01, 1.7361D-02/ + DATA H/ -4.44444D-01, -3.472D-03, 4.44444D-01, 1.7361D-02/ ! - DATA A, B/ 2.2D00, - 1.72D00/ + DATA A, B/ 2.2D00, - 1.72D00/ ! - IF (K>=0 .AND. K<=1) THEN - IF (X <= 2.0D00) THEN - IF (X == 0.0D00) GO TO 6 + IF (K>=0 .AND. K<=1) THEN + IF (X <= 2.0D00) THEN + IF (X == 0.0D00) GO TO 6 ! ! Use rational approximation for X < 2 ! - K1 = K + 1 - SUM = 0.0D00 - XN = 1.0D00 - DO I = 1, 6 - SUM = SUM + XN*F(I,K1) - XN = XN*X - END DO - X2 = X*X - SUMG = G(1,K1) + X2*(G(2,K1)+X2*G(3,K1)) - SUMH = H(1,K1) + X2*X2*H(2,K1) - XN = LOG(X) - SUMG = XN*(SUMG + XN*SUMH) - IF (K /= 0) THEN - SUM = SUM + SUMG - GO TO 7 - ENDIF - SUM = SUM + X*SUMG - GO TO 7 - ENDIF + K1 = K + 1 + SUM = 0.0D00 + XN = 1.0D00 + DO I = 1, 6 + SUM = SUM + XN*F(I,K1) + XN = XN*X + END DO + X2 = X*X + SUMG = G(1,K1) + X2*(G(2,K1)+X2*G(3,K1)) + SUMH = H(1,K1) + X2*X2*H(2,K1) + XN = LOG(X) + SUMG = XN*(SUMG + XN*SUMH) + IF (K /= 0) THEN + SUM = SUM + SUMG + GO TO 7 + ENDIF + SUM = SUM + X*SUMG + GO TO 7 + ENDIF ! - SUM = A + B/X - IF (K /= 0) SUM = SUM + (SUM + B/X)/X - SUM = SUM/X - XM = -X - SUM = SUM*EXP(XM) - GO TO 7 - 6 CONTINUE - IF (K == 1) GO TO 98 - SUM = F(1,1) - 7 CONTINUE - FUNL = SUM - RETURN + SUM = A + B/X + IF (K /= 0) SUM = SUM + (SUM + B/X)/X + SUM = SUM/X + XM = -X + SUM = SUM*EXP(XM) + GO TO 7 + 6 CONTINUE + IF (K == 1) GO TO 98 + SUM = F(1,1) + 7 CONTINUE + FUNL = SUM + RETURN ! ! Error section ! - 98 CONTINUE - WRITE (*, 302) - STOP - ENDIF - WRITE (*, 301) - STOP + 98 CONTINUE + WRITE (*, 302) + STOP + ENDIF + WRITE (*, 301) + STOP ! - 301 FORMAT(/,'FUNL: K must be either 0 or 1') + 301 FORMAT(/,'FUNL: K must be either 0 or 1') 302 FORMAT(/,'FUNL: Attempt to calculate function for'/,& - ' zero argument and K value of 1') - RETURN + ' zero argument and K value of 1') + RETURN ! - END FUNCTION FUNL + END FUNCTION FUNL diff --git a/src/appl/rci90/funl_I.f90 b/src/appl/rci90/funl_I.f90 index f30cdf39d..a35832f88 100644 --- a/src/appl/rci90/funl_I.f90 +++ b/src/appl/rci90/funl_I.f90 @@ -1,13 +1,13 @@ - MODULE funl_I + MODULE funl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION funl (X, K) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: X - INTEGER, INTENT(IN) :: K + REAL(KIND(0.0D0)) FUNCTION funl (X, K) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: K !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/fzalf.f90 b/src/appl/rci90/fzalf.f90 index 8801d1f81..e997e887f 100644 --- a/src/appl/rci90/fzalf.f90 +++ b/src/appl/rci90/fzalf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) ! * ! An estimate of the function F (Z*\alpha) is computed here. * ! * @@ -10,44 +10,44 @@ REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE mohr_I - USE klamaq_I + USE mohr_I + USE klamaq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: KAPPA - REAL(DOUBLE) :: Z + INTEGER :: N + INTEGER :: KAPPA + REAL(DOUBLE) :: Z !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEFF - REAL(DOUBLE) :: VALUE + INTEGER :: NEFF + REAL(DOUBLE) :: VALUE !----------------------------------------------- ! - IF (N <= 2) THEN - CALL MOHR (N, KAPPA, Z, VALUE) - ELSE - IF (KAPPA==(-1) .OR. KAPPA==1 .OR. KAPPA==(-2)) THEN - NEFF = 2 - CALL MOHR (NEFF, KAPPA, Z, VALUE) - ELSE - CALL KLAMAQ (N, KAPPA, Z, VALUE) - ENDIF - ENDIF + IF (N <= 2) THEN + CALL MOHR (N, KAPPA, Z, VALUE) + ELSE + IF (KAPPA==(-1) .OR. KAPPA==1 .OR. KAPPA==(-2)) THEN + NEFF = 2 + CALL MOHR (NEFF, KAPPA, Z, VALUE) + ELSE + CALL KLAMAQ (N, KAPPA, Z, VALUE) + ENDIF + ENDIF ! - FZALF = VALUE + FZALF = VALUE ! - RETURN - END FUNCTION FZALF + RETURN + END FUNCTION FZALF diff --git a/src/appl/rci90/fzalf_I.f90 b/src/appl/rci90/fzalf_I.f90 index 63a53ef65..b35b837fa 100644 --- a/src/appl/rci90/fzalf_I.f90 +++ b/src/appl/rci90/fzalf_I.f90 @@ -1,13 +1,13 @@ - MODULE fzalf_I + MODULE fzalf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION fzalf (N, KAPPA, Z) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION fzalf (N, KAPPA, Z) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/genintbreit1.f90 b/src/appl/rci90/genintbreit1.f90 index 77b7a54ac..ace21a614 100644 --- a/src/appl/rci90/genintbreit1.f90 +++ b/src/appl/rci90/genintbreit1.f90 @@ -17,7 +17,7 @@ SUBROUTINE genintbreit1 (myid, nprocs, NB, j2max) ! Written by Per Jonsson October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/genintbreit1_I.f90 b/src/appl/rci90/genintbreit1_I.f90 index 11e494a00..2c2d3d42a 100644 --- a/src/appl/rci90/genintbreit1_I.f90 +++ b/src/appl/rci90/genintbreit1_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit1_I + MODULE genintbreit1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit1 (myid, nprocs, NB, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: NB, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/genintbreit2.f90 b/src/appl/rci90/genintbreit2.f90 index 97ee2bf58..170da493e 100644 --- a/src/appl/rci90/genintbreit2.f90 +++ b/src/appl/rci90/genintbreit2.f90 @@ -17,7 +17,7 @@ SUBROUTINE genintbreit2 (myid, nprocs, NB, j2max) ! Written by Per Jonsson October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/genintbreit2_I.f90 b/src/appl/rci90/genintbreit2_I.f90 index 2689029e6..b6d801855 100644 --- a/src/appl/rci90/genintbreit2_I.f90 +++ b/src/appl/rci90/genintbreit2_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit2_I + MODULE genintbreit2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit2 (myid, nprocs, NB, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: NB, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/genintrk.f90 b/src/appl/rci90/genintrk.f90 index 8c0d3beda..669b9ef7f 100644 --- a/src/appl/rci90/genintrk.f90 +++ b/src/appl/rci90/genintrk.f90 @@ -15,8 +15,8 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) ! MPI version by Xinghong He Last revision: 22 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -43,7 +43,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) LOGICAL :: GEN,TRIANGRK INTEGER :: key, i, k, ia, ib, ic, id !----------------------------------------------------------------------- - + KEY = NW + 1 KSTART(0) = 1 ! @@ -53,7 +53,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) DO I = 2, NW IF (NKJ(I) .GT. J2MAX) J2MAX = NKJ(I) ENDDO - + IF (J2MAX .GT. KMAX) THEN STOP 'genintrk: KMAX too small' ENDIF @@ -62,7 +62,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) ! When GEN is false, sweep through to find dimension ! GEN = .FALSE. - + 999 N = 0 DO K = 0, J2MAX DO IA = 1, NW @@ -90,20 +90,20 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) IF (.NOT. GEN) THEN CALL ALLOC (INDTEIRK,N,'INDTEIRK', 'GENINTRK') CALL ALLOC (VALTEIRK,N,'VALTEIRK', 'GENINTRK') - + ! Initialization is necessary in the mpi version - + DO i = 1, N INDTEIRK(i) = 0 VALTEIRK(i) = 0.d0 ENDDO - + IF (myid .EQ. 0) & & PRINT *, 'Allocating space for ',N,' Rk integrals' - + GEN = .TRUE. GOTO 999 ENDIF - + RETURN END diff --git a/src/appl/rci90/genintrk_I.f90 b/src/appl/rci90/genintrk_I.f90 index b8379c9fc..58c80ce2e 100644 --- a/src/appl/rci90/genintrk_I.f90 +++ b/src/appl/rci90/genintrk_I.f90 @@ -1,11 +1,11 @@ - MODULE genintrk_I + MODULE genintrk_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintrk (myid, nprocs, N, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER, INTENT(OUT) :: N, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/genmat.f90 b/src/appl/rci90/genmat.f90 index 858d19530..00ea954b2 100644 --- a/src/appl/rci90/genmat.f90 +++ b/src/appl/rci90/genmat.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) + SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) ! ! Generate Hamiltonian matrix for all blocks ! This routine calls setham to do the computation. It makes @@ -13,13 +13,13 @@ SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) ! Xinghong He 1998-06-23 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE eigv_C USE iccu_C USE orb_C @@ -30,101 +30,101 @@ SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE posfile_I - USE setham_I + USE posfile_I + USE setham_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JBLOCK - INTEGER :: MYID - INTEGER :: NPROCS - INTEGER, INTENT(OUT) :: IRESTART - REAL(DOUBLE) :: ATWINV - REAL(DOUBLE) :: ELSTO + INTEGER :: JBLOCK + INTEGER :: MYID + INTEGER :: NPROCS + INTEGER, INTENT(OUT) :: IRESTART + REAL(DOUBLE) :: ATWINV + REAL(DOUBLE) :: ELSTO REAL(DOUBLE), DIMENSION(*) :: SLF_EN !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IREAD, IOS, NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM, I, & - IOS2, NELC, IR, IROWDUM, IPOS, NROWS, J, ICSTRT + IOS2, NELC, IR, IROWDUM, IPOS, NROWS, J, ICSTRT REAL(DOUBLE) :: STOEL, DUM, EAV0 !----------------------------------------------- ! - NELMNT = 0 ! Counting continues in setham - EAV = 0.D0 - ELSTO = 0.D0 - + NELMNT = 0 ! Counting continues in setham + EAV = 0.D0 + ELSTO = 0.D0 + ! See how much had been done (Hamiltonian matrix) ! irestart is set; ! iread accumulated; ! nelmnt, eav, elsto obtained (to be further modified in setham) - - IREAD = 0 ! # of rows read, initialization necessary - - READ (IMCDF, IOSTAT=IOS) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM - IRESTART = IOS - - IF (IOS == 0) THEN - + + IREAD = 0 ! # of rows read, initialization necessary + + READ (IMCDF, IOSTAT=IOS) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + IRESTART = IOS + + IF (IOS == 0) THEN + IF (NCF/=NCFDUM .OR. ICCUT(1)/=ICCUTDUM .OR. MYID/=MYIDDUM .OR. & - NPROCS/= NPROCSDUM) THEN + NPROCS/= NPROCSDUM) THEN WRITE (ISTDE, *) NCF, NCFDUM, ICCUT(1), ICCUTDUM, MYID, MYIDDUM, & - NPROCS, NPROCSDUM, 'check' - STOP 'genmat:1' - ENDIF - - DO I = MYID + 1, NCF, NPROCS + NPROCS, NPROCSDUM, 'check' + STOP 'genmat:1' + ENDIF + + DO I = MYID + 1, NCF, NPROCS READ (IMCDF, IOSTAT=IOS2) NELC, STOEL, (DUM,IR=2,NELC), EAV0, (& - IROWDUM,IR=1,NELC) + IROWDUM,IR=1,NELC) ! Lower triangle row-mode, diagonal last - IF (IOS2 == 0) THEN - IREAD = IREAD + 1 - NELMNT = NELMNT + NELC - EAV = EAV + EAV0 - ELSTO = STOEL - ELSE - EXIT - ENDIF - END DO - IPOS = 7 + NW + NW + IREAD + 1 - ELSE - IPOS = 7 + NW + NW - ENDIF - + IF (IOS2 == 0) THEN + IREAD = IREAD + 1 + NELMNT = NELMNT + NELC + EAV = EAV + EAV0 + ELSTO = STOEL + ELSE + EXIT + ENDIF + END DO + IPOS = 7 + NW + NW + IREAD + 1 + ELSE + IPOS = 7 + NW + NW + ENDIF + ! Find the maximum number of rows - - NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS - IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) - + + NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS + IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) + ! Report the number of rows read. ! A more suitable report on all nodes can be done here, but this will ! set a synchronization point. - - WRITE (ISTDE, *) IREAD, ' (total ', NROWS, ') rows read from .res' + + WRITE (ISTDE, *) IREAD, ' (total ', NROWS, ') rows read from .res' IF (MYID == 0) WRITE (24, *) IREAD, ' (total ', NROWS, & - ') rows read from .res' - + ') rows read from .res' + ! Position the file for the next record from setham - - DO I = 1, JBLOCK - 1 - J = (NCFBLK(I) - MYID - 1 + NPROCS)/NPROCS - IF (NCFBLK(I) < NPROCS) J = NCFBLK(I)/(MYID + 1) - IPOS = IPOS + J + 1 - END DO - CALL POSFILE (0, IMCDF, IPOS) - - IF (IOS /= 0) WRITE (IMCDF) NCF, ICCUT(1), MYID, NPROCS - - IF (IREAD < NROWS) THEN - ICSTRT = IREAD*NPROCS + MYID + 1 + + DO I = 1, JBLOCK - 1 + J = (NCFBLK(I) - MYID - 1 + NPROCS)/NPROCS + IF (NCFBLK(I) < NPROCS) J = NCFBLK(I)/(MYID + 1) + IPOS = IPOS + J + 1 + END DO + CALL POSFILE (0, IMCDF, IPOS) + + IF (IOS /= 0) WRITE (IMCDF) NCF, ICCUT(1), MYID, NPROCS + + IF (IREAD < NROWS) THEN + ICSTRT = IREAD*NPROCS + MYID + 1 ! ...Generate the rest of the Hamiltonian matrix CALL SETHAM (MYID, NPROCS, JBLOCK, ELSTO, ICSTRT, NELMNT, ATWINV, & - SLF_EN) - ELSE - NELMNTTMP = NELMNT - NCFTMP = NCF - ENDIF - - RETURN - END SUBROUTINE GENMAT + SLF_EN) + ELSE + NELMNTTMP = NELMNT + NCFTMP = NCF + ENDIF + + RETURN + END SUBROUTINE GENMAT diff --git a/src/appl/rci90/genmat2.f90 b/src/appl/rci90/genmat2.f90 index a9a727bc4..3024f0f3d 100644 --- a/src/appl/rci90/genmat2.f90 +++ b/src/appl/rci90/genmat2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) + SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! ! Get eav and do writings to the summary file .csum ! The mpi version (genmat2mpi) also gets nelmnt_a and elsto @@ -8,11 +8,11 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! Xinghong He 98-06-15 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE, LONG USE hmat_C !! rather than setham_to_genmat2 @@ -22,14 +22,14 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IRESTART - INTEGER(LONG), INTENT(OUT) :: NELMNT_A - REAL(DOUBLE), INTENT(IN) :: ELSTO + INTEGER, INTENT(IN) :: IRESTART + INTEGER(LONG), INTENT(OUT) :: NELMNT_A + REAL(DOUBLE), INTENT(IN) :: ELSTO !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(6) :: NTPI_A - REAL(DOUBLE) :: DENSTY + INTEGER, DIMENSION(6) :: NTPI_A + REAL(DOUBLE) :: DENSTY !----------------------------------------------- !----------------------------------------------------------------------- ! Transfer parameters around and print out on node-0. @@ -39,25 +39,25 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! The following parameters are accumulated in setham which will not ! contain the correct values in restart mode. And thus is skipped. !----------------------------------------------------------------------- - IF (IRESTART /= 0) THEN ! non-restart mode - WRITE (24, 301) CUTOFFTMP - WRITE (24, 302) NCOEITMP - WRITE (24, 303) NCOECTMP - WRITE (24, 304) NCTEITMP - WRITE (24, 305) NCTECTMP - IF (LTRANS) THEN - WRITE (24, 306) NTPITMP - WRITE (24, 307) NMCBPTMP - WRITE (24, 308) NCORETMP - ENDIF - IF (LVP) WRITE (24, 309) NVPITMP - IF (LNMS) WRITE (24, 310) NKEITMP - IF (LSMS) WRITE (24, 311) NVINTITMP - ELSE - WRITE (24, *) 'Restart mode --- no report on radial integrals' - ENDIF !(irestart .NE. 0) ! non-restart mode - - + IF (IRESTART /= 0) THEN ! non-restart mode + WRITE (24, 301) CUTOFFTMP + WRITE (24, 302) NCOEITMP + WRITE (24, 303) NCOECTMP + WRITE (24, 304) NCTEITMP + WRITE (24, 305) NCTECTMP + IF (LTRANS) THEN + WRITE (24, 306) NTPITMP + WRITE (24, 307) NMCBPTMP + WRITE (24, 308) NCORETMP + ENDIF + IF (LVP) WRITE (24, 309) NVPITMP + IF (LNMS) WRITE (24, 310) NKEITMP + IF (LSMS) WRITE (24, 311) NVINTITMP + ELSE + WRITE (24, *) 'Restart mode --- no report on radial integrals' + ENDIF !(irestart .NE. 0) ! non-restart mode + + !----------------------------------------------------------------------- ! ELSTO, EAV are not only for print-out, but also used later. ! density of the Hamiltonian matrix is only for print-out. @@ -65,34 +65,34 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! _not_ contain ELSTO. ELSTO will be added to the total energy ! later with EAV. !----------------------------------------------------------------------- - - NELMNT_A = NELMNTTMP - - DENSTY = DBLE(NELMNTTMP)/DBLE((NCFTMP*(NCFTMP + 1))/2) - - EAV = EAV/DBLE(NCFTMP) + ELSTO - - WRITE (24, 312) NELMNTTMP - WRITE (24, 313) DENSTY - WRITE (24, *) - WRITE (24, 300) EAV - WRITE (24, *) EAV, ELSTO, NCFTMP - - 300 FORMAT('Average energy = ',1P,D19.12,' Hartrees.') - 301 FORMAT('CUTOFF set to ',1P,D17.10) - 302 FORMAT('Dirac-Coulomb one-e radial integrals:',1I8) - 303 FORMAT('One-e angular integrals that exceed CUTOFF: ',1I8) - 304 FORMAT('Coulomb two-e radial integrals: ',1I8) - 305 FORMAT('Two-e angular integrals that exceed CUTOFF: ',1I8) - 306 FORMAT('Transverse two-e radial integrals: '/,6I8) - 307 FORMAT('MCBP coefficients that exceed CUTOFF: ',1I8) - 308 FORMAT('Core coefficients that exceed CUTOFF: ',1I8) - 309 FORMAT('Vacuum polarisation integrals: ',1I8) - 310 FORMAT('Kinetic energy integrals: ',1I8) - 311 FORMAT('Vinti integrals: ',1I8) + + NELMNT_A = NELMNTTMP + + DENSTY = DBLE(NELMNTTMP)/DBLE((NCFTMP*(NCFTMP + 1))/2) + + EAV = EAV/DBLE(NCFTMP) + ELSTO + + WRITE (24, 312) NELMNTTMP + WRITE (24, 313) DENSTY + WRITE (24, *) + WRITE (24, 300) EAV + WRITE (24, *) EAV, ELSTO, NCFTMP + + 300 FORMAT('Average energy = ',1P,D19.12,' Hartrees.') + 301 FORMAT('CUTOFF set to ',1P,D17.10) + 302 FORMAT('Dirac-Coulomb one-e radial integrals:',1I8) + 303 FORMAT('One-e angular integrals that exceed CUTOFF: ',1I8) + 304 FORMAT('Coulomb two-e radial integrals: ',1I8) + 305 FORMAT('Two-e angular integrals that exceed CUTOFF: ',1I8) + 306 FORMAT('Transverse two-e radial integrals: '/,6I8) + 307 FORMAT('MCBP coefficients that exceed CUTOFF: ',1I8) + 308 FORMAT('Core coefficients that exceed CUTOFF: ',1I8) + 309 FORMAT('Vacuum polarisation integrals: ',1I8) + 310 FORMAT('Kinetic energy integrals: ',1I8) + 311 FORMAT('Vinti integrals: ',1I8) 312 FORMAT('Elements that exceed CUTOFF in the lower',& - ' triangle of the H matrix: ',1I8) - 313 FORMAT('Density of the H(amiltonian) matrix: ',1P,D22.15) - - RETURN - END SUBROUTINE GENMAT2 + ' triangle of the H matrix: ',1I8) + 313 FORMAT('Density of the H(amiltonian) matrix: ',1P,D22.15) + + RETURN + END SUBROUTINE GENMAT2 diff --git a/src/appl/rci90/genmat2_I.f90 b/src/appl/rci90/genmat2_I.f90 index cc7b7f041..e885da22c 100644 --- a/src/appl/rci90/genmat2_I.f90 +++ b/src/appl/rci90/genmat2_I.f90 @@ -1,13 +1,13 @@ - MODULE genmat2_I + MODULE genmat2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genmat2 (IRESTART, NELMNT_A, ELSTO) - USE vast_kind_param, ONLY: DOUBLE, LONG - INTEGER, INTENT(IN) :: IRESTART - INTEGER(LONG), INTENT(OUT) :: NELMNT_A - REAL(DOUBLE), INTENT(IN) :: ELSTO - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE genmat2 (IRESTART, NELMNT_A, ELSTO) + USE vast_kind_param, ONLY: DOUBLE, LONG + INTEGER, INTENT(IN) :: IRESTART + INTEGER(LONG), INTENT(OUT) :: NELMNT_A + REAL(DOUBLE), INTENT(IN) :: ELSTO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/genmat_I.f90 b/src/appl/rci90/genmat_I.f90 index 8e1b5d9bc..6cfdf5acf 100644 --- a/src/appl/rci90/genmat_I.f90 +++ b/src/appl/rci90/genmat_I.f90 @@ -1,18 +1,18 @@ - MODULE genmat_I + MODULE genmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genmat (ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE) :: ATWINV + SUBROUTINE genmat (ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE) :: ATWINV !VAST...Dummy argument ATWINV is not referenced in this routine. - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - REAL(DOUBLE), INTENT(OUT) :: ELSTO - INTEGER, INTENT(OUT) :: IRESTART + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + REAL(DOUBLE), INTENT(OUT) :: ELSTO + INTEGER, INTENT(OUT) :: IRESTART REAL(DOUBLE), DIMENSION(*) :: SLF_EN - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/getcid.f90 b/src/appl/rci90/getcid.f90 index 609636e5e..ca05fee4b 100644 --- a/src/appl/rci90/getcid.f90 +++ b/src/appl/rci90/getcid.f90 @@ -12,8 +12,8 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! Block version by Xinghong He Last revision: 15 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -87,23 +87,23 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ELSE LFORDR = .FALSE. ENDIF - + ! Get iccutblk() from the user-input - + IF (.NOT. LFORDR) THEN !...Default first DO i = 1, nblock iccutblk(i) = ncfblk(i) ENDDO ELSE - + ! Let master do the i/o, then broadcast WRITE (istde,*) 'There are ', nblock, 'blocks. They are:' WRITE (istde,*) ' block J Parity No of CSFs' DO i = 1, nblock WRITE (istde,*) i, idblk(i)(1:5), ncfblk(i) ENDDO - + WRITE (istde,*) WRITE (istde,*) 'Enter iccut for each block' DO jblock = 1, nblock @@ -120,16 +120,16 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) write(734,*) ntmp,'! ICCUT for block',jblock ENDDO ENDIF - + !***************************************************************** ! ! Pre-run ? ! ! IF (IPRERUN .EQ. 0) THEN - + ! WRITE (istde,*) ' Prerun with limited interaction?' ! YES = GETYN () - + ! IF (YES) THEN ! IPRERUN = 1 ! LTRANS = .FALSE. @@ -137,7 +137,7 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! LNMS = .FALSE. ! LSMS = .FALSE. ! LSE = .FALSE. - + ! WRITE (istde,*) ' Give CSL cut' ! READ *, NCSFPRE ! WRITE (istde,*) ' Give coefficient cut for H_0' @@ -167,13 +167,13 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! WRITE (istde,*) 'Include H (Vacuum Polarisation)?' LVP = GETYN () - + WRITE (istde,*) 'Include H (Normal Mass Shift)?' LNMS = GETYN () - + WRITE (istde,*) 'Include H (Specific Mass Shift)?' LSMS = GETYN () - + WRITE (istde,*) 'Estimate self-energy?' LSE = GETYN () IF (LSE.EQV..TRUE.) THEN @@ -244,7 +244,7 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! WRITE (istde,*) ' N = ',N,';' ! WRITE (istde,*) ' revise these values?' ! YES = GETYN () -! +! ! IF (YES) THEN ! WRITE (istde,*) 'Enter RNT:' ! READ *, RNT diff --git a/src/appl/rci90/getcid_I.f90 b/src/appl/rci90/getcid_I.f90 index aa9b87df7..5b2fc05b9 100644 --- a/src/appl/rci90/getcid_I.f90 +++ b/src/appl/rci90/getcid_I.f90 @@ -1,11 +1,11 @@ - MODULE getcid_I + MODULE getcid_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE GETCID (isofile, rwffile, idblk) CHARACTER(LEN=*):: isofile, rwffile CHARACTER(LEN=8), DIMENSION(*) :: idblk - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/hmout.f90 b/src/appl/rci90/hmout.f90 index ed036b573..56e6777a3 100644 --- a/src/appl/rci90/hmout.f90 +++ b/src/appl/rci90/hmout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE HMOUT(IMCDF) + SUBROUTINE HMOUT(IMCDF) ! * ! Routine for printing the Hamiltonian matrix. File IMCDF must be * ! positioned correctly before a call is made to this module. * @@ -10,42 +10,42 @@ SUBROUTINE HMOUT(IMCDF) ! Written by Farid A Parpia Last revision: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE hmat_C USE orb_C, ONLY: ncf, nw, iqa !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IMCDF + INTEGER, INTENT(IN) :: IMCDF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IC, NELC, IR, LENTHR, LENTHC - REAL(DOUBLE) :: ELSTO - CHARACTER :: CIR*8, CIC*8 + INTEGER :: IC, NELC, IR, LENTHR, LENTHC + REAL(DOUBLE) :: ELSTO + CHARACTER :: CIR*8, CIC*8 !----------------------------------------------- ! - DO IC = 1, NCF - READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) - DO IR = 1, NELC - CALL CONVRT (IROW(IR), CIR, LENTHR) - CALL CONVRT (IC, CIC, LENTHC) - WRITE (99, 300) CIR(1:LENTHR), CIC(1:LENTHC), EMT(IR) - END DO - END DO + DO IC = 1, NCF + READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) + DO IR = 1, NELC + CALL CONVRT (IROW(IR), CIR, LENTHR) + CALL CONVRT (IC, CIC, LENTHC) + WRITE (99, 300) CIR(1:LENTHR), CIC(1:LENTHC), EMT(IR) + END DO + END DO ! - 300 FORMAT(' H (',A,',',A,') = ',1P,1D19.12) - RETURN + 300 FORMAT(' H (',A,',',A,') = ',1P,1D19.12) + RETURN ! - END SUBROUTINE HMOUT + END SUBROUTINE HMOUT diff --git a/src/appl/rci90/hmout_I.f90 b/src/appl/rci90/hmout_I.f90 index 83f43a6ec..bc8ec631e 100644 --- a/src/appl/rci90/hmout_I.f90 +++ b/src/appl/rci90/hmout_I.f90 @@ -1,10 +1,10 @@ - MODULE hmout_I + MODULE hmout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE hmout (IMCDF) - INTEGER, INTENT(IN) :: IMCDF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE hmout (IMCDF) + INTEGER, INTENT(IN) :: IMCDF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/hovlap.f90 b/src/appl/rci90/hovlap.f90 index 9c86dda0d..6405627e5 100644 --- a/src/appl/rci90/hovlap.f90 +++ b/src/appl/rci90/hovlap.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) ! * ! This subprogram computes the overlap of the orbital tabulated in * ! the arrays P and Q with maximum tabulation point MTPO with * @@ -11,13 +11,13 @@ REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C USE horb_C, ONLY: ph, qh @@ -25,37 +25,37 @@ REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dcbsrw_I - USE quad_I + USE dcbsrw_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPH, I - REAL(DOUBLE) :: EH, PZH, RESULT + INTEGER :: MTPH, I + REAL(DOUBLE) :: EH, PZH, RESULT !----------------------------------------------- ! ! Set up the hydrogenic orbital ! - CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) + CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) ! ! Compute the overlap ! - MTP = MIN(MTPH,MTPO) - TA(1) = 0.0D00 - TA(2:MTP) = (P(2:MTP)*PH(2:MTP)+Q(2:MTP)*QH(2:MTP))*RP(2:MTP) - CALL QUAD (RESULT) + MTP = MIN(MTPH,MTPO) + TA(1) = 0.0D00 + TA(2:MTP) = (P(2:MTP)*PH(2:MTP)+Q(2:MTP)*QH(2:MTP))*RP(2:MTP) + CALL QUAD (RESULT) ! - HOVLAP = RESULT + HOVLAP = RESULT ! - RETURN - END FUNCTION HOVLAP + RETURN + END FUNCTION HOVLAP diff --git a/src/appl/rci90/hovlap_I.f90 b/src/appl/rci90/hovlap_I.f90 index 0678c830a..31b981263 100644 --- a/src/appl/rci90/hovlap_I.f90 +++ b/src/appl/rci90/hovlap_I.f90 @@ -1,17 +1,17 @@ - MODULE hovlap_I + MODULE hovlap_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION hovlap (P, Q, MTPO, NP, KAPPA, Z) - USE vast_kind_param, ONLY: DOUBLE + REAL(KIND(0.0D0)) FUNCTION hovlap (P, Q, MTPO, NP, KAPPA, Z) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/iabint.f90 b/src/appl/rci90/iabint.f90 index eb8dbd27c..00f4e826c 100644 --- a/src/appl/rci90/iabint.f90 +++ b/src/appl/rci90/iabint.f90 @@ -13,8 +13,8 @@ SUBROUTINE IABINT (IA,IB,TEGRAL) ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/iabint_I.f90 b/src/appl/rci90/iabint_I.f90 index eeb8bfa8e..9e5e12753 100644 --- a/src/appl/rci90/iabint_I.f90 +++ b/src/appl/rci90/iabint_I.f90 @@ -1,12 +1,12 @@ - MODULE iabint_I + MODULE iabint_I INTERFACE SUBROUTINE IABINT (IA,IB,TEGRAL) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 USE vast_kind_param, ONLY: DOUBLE INTEGER, INTENT(INOUT) :: ia, ib REAL(DOUBLE), INTENT(out) :: tegral - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/indtpi.f90 b/src/appl/rci90/indtpi.f90 index c38584b7f..d83771cad 100644 --- a/src/appl/rci90/indtpi.f90 +++ b/src/appl/rci90/indtpi.f90 @@ -1,12 +1,12 @@ !*********************************************************************** ! * - INTEGER FUNCTION INDTPI (ITYPE, I) + INTEGER FUNCTION INDTPI (ITYPE, I) ! * ! Written by Farid A Parpia Last revision: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 USE bilst_C !----------------------------------------------- @@ -16,24 +16,24 @@ INTEGER FUNCTION INDTPI (ITYPE, I) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: I + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: I !----------------------------------------------- ! - SELECT CASE (ITYPE) - CASE (1) - INDTPI = INDTP1(I) - CASE (2) - INDTPI = INDTP2(I) - CASE (3) - INDTPI = INDTP3(I) - CASE (4) - INDTPI = INDTP4(I) - CASE (5) - INDTPI = INDTP5(I) - CASE (6) - INDTPI = INDTP6(I) - END SELECT + SELECT CASE (ITYPE) + CASE (1) + INDTPI = INDTP1(I) + CASE (2) + INDTPI = INDTP2(I) + CASE (3) + INDTPI = INDTP3(I) + CASE (4) + INDTPI = INDTP4(I) + CASE (5) + INDTPI = INDTP5(I) + CASE (6) + INDTPI = INDTP6(I) + END SELECT ! - RETURN - END FUNCTION INDTPI + RETURN + END FUNCTION INDTPI diff --git a/src/appl/rci90/indtpi_I.f90 b/src/appl/rci90/indtpi_I.f90 index c25481ad3..e21225c73 100644 --- a/src/appl/rci90/indtpi_I.f90 +++ b/src/appl/rci90/indtpi_I.f90 @@ -1,11 +1,11 @@ - MODULE indtpi_I + MODULE indtpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION indtpi (ITYPE, I) - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: I - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION indtpi (ITYPE, I) + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: I + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/iniestdm.f90 b/src/appl/rci90/iniestdm.f90 index 553b27d0e..856e706c0 100644 --- a/src/appl/rci90/iniestdm.f90 +++ b/src/appl/rci90/iniestdm.f90 @@ -1,7 +1,7 @@ !************************************************************************ ! SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) - + ! Routine for providing initial estimates from the diagonal ! of the matrix. This way was used by Dvdson in atomic structure ! calculations. It should be used to obtain estimates when nothing @@ -10,8 +10,8 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) ! Block version by Xinghong He Last revision: 18 Jun 1998 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -36,50 +36,50 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) REAL(DOUBLE), DIMENSION(:), pointer :: ap, eigval, vec, work INTEGER, DIMENSION(:), pointer :: iwork, ifail !----------------------------------------------------------------------- - + myid = 0 nprocs = 1 - + NS = MIN (nmax, ncf) - + CALL alloc (ap, NS*(NS+1)/2, 'AP', 'INIESTDM') CALL dinit (NS*(NS+1)/2, 0.d0, ap, 1) - + ! Get the upper left sub-matrix - + DO i = 1, (ns*(ns+1))/2 ap(i) = hmx(i) ENDDO - + CALL alloc (eigval, NS, 'EIGVAL', 'INIESTDM') CALL alloc (vec, NS*NIV, 'VEC', 'INIESTDM') CALL alloc (work, 8*NS, 'WORK', 'INIESTDM') CALL alloc (iwork, 5*NS, 'IWORK', 'INIESTDM') CALL alloc (ifail, NS, 'IFAIL', 'INIESTDM') - + CALL DSPEVX ('Vectors also','In a range','Upper triangular', & & NS,AP,-1.0D0,-1.0D0,1,NIV,0.d0, & & NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) IERR = -ABS (INFO) - + ! Build the Basis. - + CALL DINIT (ncf*NIV, 0.D0, BASIS, 1) - + ! scatter the vectors - + DO J = 1, NIV CALL dcopy (ns, vec(ns*(j-1)+1),1, basis(ncf*(j-1)+1), 1) ENDDO - + CALL dcopy (NIV, EIGVAL, 1, BASIS(NIV*ncf+1), 1) - + CALL dalloc (ap, 'AP', 'INIESTDM') CALL dalloc (eigval, 'EIGVAL', 'INIESTDM') CALL dalloc (vec, 'VEC', 'INIESTDM') CALL dalloc (work, 'WORK', 'INIESTDM') CALL dalloc (iwork, 'IWORK', 'INIESTDM') CALL dalloc (ifail, 'IFAIL', 'INIESTDM') - + RETURN END diff --git a/src/appl/rci90/iniestdm_I.f90 b/src/appl/rci90/iniestdm_I.f90 index 57ad5401c..97a146f4f 100644 --- a/src/appl/rci90/iniestdm_I.f90 +++ b/src/appl/rci90/iniestdm_I.f90 @@ -1,12 +1,12 @@ - MODULE iniestdm_I + MODULE iniestdm_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN):: nmax, ncf, niv REAL(DOUBLE), DIMENSION(*) :: basis, hmx END SUBROUTINE INIESTDM - END INTERFACE - END MODULE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/iniestsd.f90 b/src/appl/rci90/iniestsd.f90 index 159e497ed..a5e0298b2 100644 --- a/src/appl/rci90/iniestsd.f90 +++ b/src/appl/rci90/iniestsd.f90 @@ -12,8 +12,8 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ! Block version by Xinghong He Last revision: 14 Dec 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -41,12 +41,12 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & REAL(DOUBLE) :: elsto !----------------------------------------------------------------------- NS = min (nmax, ncf) - + CALL alloc (ap, (NS*(NS+1))/2, 'AP', 'INIESTSD') CALL dinit ((NS*(NS+1))/2, 0.d0, ap, 1) - + !**** separate upper left block of size NS*NS - + CALL alloc (hmx, ncf, 'HMX', 'INIESTSD') CALL alloc (irow, ncf, 'IROW', 'INIESTSD') READ (imcdf) ncfdum, iccutdum, myiddum, nprocsdum @@ -54,10 +54,10 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & IF (ncf .NE. ncfdum .OR. myid .NE. myiddum & .OR. nprocsdum .NE. nprocs) & STOP 'iniestsd: ncf read wrong' - + ! if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; ! if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. - + DO j = myid + 1, ns, nprocs joff = (j*(j-1))/2 READ (IMCDF) NELC,ELSTO,(HMX(IR),IR=1,NELC), & @@ -67,11 +67,11 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ap(irow(ir) + joff) = hmx(ir) ENDDO ENDDO - + ! Let each node have a complete copy of ap - + ! CALL gdsummpi (ap, (NS*(NS+1))/2) - + ! To be in step with other cases, go through the whole block. ! ! This is not necessary since currently the file pointer is moved @@ -79,43 +79,43 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ! from the begining of the .res files of each node. Besides, the ! following segment seems not working properly for the last block. ! Xinghong He 98-12-14 - + !mylast = j - nprocs !DO j = mylast, ncf, nprocs ! READ (imcdf) !ENDDO - + CALL dalloc (hmx,'HMX', 'INIESTSD') CALL dalloc (irow, 'HMX', 'INIESTSD') - + CALL alloc (eigval,NS,'EIGVAL','INIESTSD') CALL alloc (vec,NS*NIV,'VEC','INIESTSD') CALL alloc (work,8*NS,'WORK','INIESTSD') CALL alloc (iwork,5*NS,'IWORK','INIESTSD' ) CALL alloc (ifail,NS, 'IFAIL','INIESTSD' ) - + CALL DSPEVX ('Vectors also','In a range','Upper triangular', & NS,AP,-1.0D0,-1.0D0,1,NIV,0.d0, & NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) IERR = -ABS (INFO) - + !****************************************************************** - + ! ..Build the Basis. - + CALL DINIT (ncf*NIV, 0.D0, BASIS, 1) ! ...scatter the vectors DO J = 1, NIV CALL dcopy (ns, vec(ns*(j-1)+1),1, basis(ncf*(j-1)+1), 1) ENDDO CALL dcopy (NIV, EIGVAL,1,BASIS(NIV*ncf+1),1) - + CALL dalloc (ap, 'AP', 'INIESTSD') CALL dalloc (eigval,'EIGVAL', 'INIESTSD') CALL dalloc (vec, 'VEC', 'INIESTSD') CALL dalloc (work, 'WORK', 'INIESTSD') CALL dalloc (iwork, 'IWORK', 'INIESTSD') CALL dalloc (ifail, 'IFAIL', 'INIESTSD') - + RETURN END SUBROUTINE INIESTSD diff --git a/src/appl/rci90/iniestsd_I.f90 b/src/appl/rci90/iniestsd_I.f90 index 2626e894d..305592cab 100644 --- a/src/appl/rci90/iniestsd_I.f90 +++ b/src/appl/rci90/iniestsd_I.f90 @@ -1,13 +1,13 @@ - MODULE iniestsd_I + MODULE iniestsd_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE INIESTSD (nmax,ncf, myid,nprocs,NIV,BASIS,IMCDF,EAV) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: nmax, ncf, myid, nprocs, niv, imcdf REAL(DOUBLE), INTENT(IN) :: EAV REAL(DOUBLE), DIMENSION(*), INTENT(IN):: Basis - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/inter_I.f90 b/src/appl/rci90/inter_I.f90 index d7cc89302..681ec7e02 100644 --- a/src/appl/rci90/inter_I.f90 +++ b/src/appl/rci90/inter_I.f90 @@ -1,10 +1,10 @@ - MODULE zkf_I + MODULE zkf_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE zkf (K, I, J) + SUBROUTINE zkf (K, I, J) ! - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/keint.f90 b/src/appl/rci90/keint.f90 index 8b1eb65a9..845120f89 100644 --- a/src/appl/rci90/keint.f90 +++ b/src/appl/rci90/keint.f90 @@ -13,8 +13,8 @@ SUBROUTINE KEINT (IA,IB,TEGRAL) ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -22,7 +22,7 @@ SUBROUTINE KEINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man - USE keilst_C + USE keilst_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- diff --git a/src/appl/rci90/keint_I.f90 b/src/appl/rci90/keint_I.f90 index 14fbaf8ef..5dae76039 100644 --- a/src/appl/rci90/keint_I.f90 +++ b/src/appl/rci90/keint_I.f90 @@ -1,12 +1,12 @@ - MODULE keint_I + MODULE keint_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE KEINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER, INTENT(INOUT) :: ia, ib REAL(DOUBLE), INTENT(out) :: tegral - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/klamaq.f90 b/src/appl/rci90/klamaq.f90 index 5c947be88..5c95b6d5b 100644 --- a/src/appl/rci90/klamaq.f90 +++ b/src/appl/rci90/klamaq.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) + SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) ! * ! The function F (Z*\alpha) is estimated here. We use the series * ! expansion given by Eqs (1) and (2) and the table of Bethe loga- * @@ -10,29 +10,29 @@ SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE), INTENT(IN) :: Z - REAL(DOUBLE), INTENT(OUT) :: FZALFA + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE), INTENT(IN) :: Z + REAL(DOUBLE), INTENT(OUT) :: FZALFA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L, LOC - REAL(DOUBLE), DIMENSION(36) :: BETHE - REAL(DOUBLE) :: C401, C402, OVLFAC, BETHEL, TERM, ZALFA, FACTOR - LOGICAL :: FIRST + INTEGER :: L, LOC + REAL(DOUBLE), DIMENSION(36) :: BETHE + REAL(DOUBLE) :: C401, C402, OVLFAC, BETHEL, TERM, ZALFA, FACTOR + LOGICAL :: FIRST !----------------------------------------------- ! DATA BETHE/ 2.9841285D00, 2.8117699D00, -0.0300167D00, 2.7676636D00, & @@ -43,87 +43,87 @@ SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) -0.0004079D00, 2.7324291D00, -0.0461552D00, -0.0085192D00, & -0.0027091D00, -0.0010945D00, -0.0004997D00, -0.0002409D00, & 2.7302673D00, -0.0467413D00, -0.0087850D00, -0.0028591D00, & - -0.0011904D00, -0.0005665D00, -0.0002904D00, -0.0001539D00/ + -0.0011904D00, -0.0005665D00, -0.0002904D00, -0.0001539D00/ ! !----------------------------------------------------------------------* ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! - DATA C401/ 0.0D00/ - DATA C402/ 0.0D00/ - DATA OVLFAC/ 0.0D00/ + DATA C401/ 0.0D00/ + DATA C402/ 0.0D00/ + DATA OVLFAC/ 0.0D00/ ! ! Set up the constants ! - IF (FIRST) THEN + IF (FIRST) THEN ! - C401 = 11.0D00/24.0D00 - C402 = 3.0D00/8.0D00 - OVLFAC = 4.0D00/3.0D00 + C401 = 11.0D00/24.0D00 + C402 = 3.0D00/8.0D00 + OVLFAC = 4.0D00/3.0D00 ! - FIRST = .FALSE. + FIRST = .FALSE. ! - ENDIF + ENDIF ! ! Ensure that the principal quantum number is in range ! - IF (N<1 .OR. N>8) THEN - WRITE (*, 300) - WRITE (*, 301) N - STOP - ENDIF + IF (N<1 .OR. N>8) THEN + WRITE (*, 300) + WRITE (*, 301) N + STOP + ENDIF ! ! Determine the azimuthal quantum number ! - IF (KAPPA > 0) THEN - L = KAPPA - ELSE IF (KAPPA == 0) THEN - WRITE (*, 300) - WRITE (*, 302) - STOP - ELSE - L = (-KAPPA) - 1 - ENDIF + IF (KAPPA > 0) THEN + L = KAPPA + ELSE IF (KAPPA == 0) THEN + WRITE (*, 300) + WRITE (*, 302) + STOP + ELSE + L = (-KAPPA) - 1 + ENDIF ! ! Ensure that the azimuthal quantum number is in range ! - IF (L > N - 1) THEN - WRITE (*, 300) - WRITE (*, 303) KAPPA, N - STOP - ENDIF + IF (L > N - 1) THEN + WRITE (*, 300) + WRITE (*, 303) KAPPA, N + STOP + ENDIF ! ! Find the appropriate entry in the table ! - LOC = (N*N - N)/2 + L + 1 - BETHEL = BETHE(LOC) + LOC = (N*N - N)/2 + L + 1 + BETHEL = BETHE(LOC) ! ! Determine the quantity in square brackets in eq. (1) of ! Klarsfeld and Maquet ! - TERM = -BETHEL + TERM = -BETHEL ! - IF (KAPPA > 0) THEN - TERM = TERM - C402/DBLE(L*(L + L + 1)) - ELSE - TERM = TERM + C402/DBLE((L + 1)*(L + L + 1)) - IF (KAPPA == (-1)) THEN - ZALFA = Z/C - FACTOR = LOG(ZALFA) - FACTOR = -(FACTOR + FACTOR) - TERM = TERM + FACTOR + C401 - ENDIF - ENDIF + IF (KAPPA > 0) THEN + TERM = TERM - C402/DBLE(L*(L + L + 1)) + ELSE + TERM = TERM + C402/DBLE((L + 1)*(L + L + 1)) + IF (KAPPA == (-1)) THEN + ZALFA = Z/C + FACTOR = LOG(ZALFA) + FACTOR = -(FACTOR + FACTOR) + TERM = TERM + FACTOR + C401 + ENDIF + ENDIF ! - FZALFA = OVLFAC*TERM + FZALFA = OVLFAC*TERM ! - RETURN + RETURN ! - 300 FORMAT('KLAMAQ:') + 300 FORMAT('KLAMAQ:') 301 FORMAT(' Principal quantum number, ',1I2,& - ', should be in the range 1--8.') - 302 FORMAT(' Kappa is 0 .') - 303 FORMAT(' Kappa, ',1I3,', is out of range for n, ',1I2,'.') - RETURN + ', should be in the range 1--8.') + 302 FORMAT(' Kappa is 0 .') + 303 FORMAT(' Kappa, ',1I3,', is out of range for n, ',1I2,'.') + RETURN ! - END SUBROUTINE KLAMAQ + END SUBROUTINE KLAMAQ diff --git a/src/appl/rci90/klamaq_I.f90 b/src/appl/rci90/klamaq_I.f90 index 83126a8dc..e0ad19cb6 100644 --- a/src/appl/rci90/klamaq_I.f90 +++ b/src/appl/rci90/klamaq_I.f90 @@ -1,14 +1,14 @@ - MODULE klamaq_I + MODULE klamaq_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE klamaq (N, KAPPA, Z, FZALFA) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE), INTENT(IN) :: Z - REAL(DOUBLE), INTENT(OUT) :: FZALFA - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE klamaq (N, KAPPA, Z, FZALFA) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE), INTENT(IN) :: Z + REAL(DOUBLE), INTENT(OUT) :: FZALFA + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/lodmix.f90 b/src/appl/rci90/lodmix.f90 index c6b58f18b..908535d2c 100644 --- a/src/appl/rci90/lodmix.f90 +++ b/src/appl/rci90/lodmix.f90 @@ -11,8 +11,8 @@ SUBROUTINE LODMIX (idblk) ! Block version by Xinghong He Last revision: 9 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -37,15 +37,15 @@ SUBROUTINE LODMIX (idblk) !----------------------------------------------- INTEGER :: ncftot, noffset, nvecsiz, jb, j !----------------------------------------------- - + ! lodstate generates ! nevblk(), ncmaxblk() ! ncmin, iccmin(1:ncmin) -- via items (memories allocated there) ! Thus we let node-0 do it and then broadcast here - + CALL alloc (ncmaxblk, nblock, 'NCMAXBLK', 'LODMIX') CALL alloc (nevblk, nblock, 'NEVBLK', 'LODMIX') - + ! print *, ' LODMIX: change lodstate arg-list - see rscf2/getold.f90 ' ! stop CALL LODSTATE (IDBLK) diff --git a/src/appl/rci90/lodmix_I.f90 b/src/appl/rci90/lodmix_I.f90 index f9d6c4682..e4c43f0b9 100644 --- a/src/appl/rci90/lodmix_I.f90 +++ b/src/appl/rci90/lodmix_I.f90 @@ -1,10 +1,10 @@ - MODULE lodmix_I + MODULE lodmix_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LODMIX (idblk) CHARACTER(LEN=8),DIMENSION(*), INTENT(IN):: idblk - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/lodres.f90 b/src/appl/rci90/lodres.f90 index 58b58165d..4cafbed63 100644 --- a/src/appl/rci90/lodres.f90 +++ b/src/appl/rci90/lodres.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRES + SUBROUTINE LODRES ! * ! Loads the data from the .res file. A number of checks are made * ! to ensure correctness and consistency. * @@ -11,13 +11,13 @@ SUBROUTINE LODRES ! Block version by Xinghong He Last revision: 1 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE memory_man USE decide_C @@ -35,14 +35,14 @@ SUBROUTINE LODRES !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setqic_I + USE getyn_I + USE setqic_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCFRES, NWRES, NBLOCKRES, I, NP10, J - LOGICAL :: YES + INTEGER :: NCFRES, NWRES, NBLOCKRES, I, NP10, J + LOGICAL :: YES !----------------------------------------------- ! ! POINTER (pncfblk, ncfblk(0:*)) @@ -50,66 +50,66 @@ SUBROUTINE LODRES ! POINTER (piccutblk, iccutblk(1)) ! !----------------------------------------------------------------------- - WRITE (6, *) 'Calling lodres ...' + WRITE (6, *) 'Calling lodres ...' ! ! Read the basic parameters of the electron cloud; check these ! against those deduced from the .csl file ! - READ (IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES - + READ (IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES + IF (NELECR/=NELEC .OR. NCFRES/=NCF .OR. NWRES/=NW .OR. NBLOCKRES/=NBLOCK& - ) STOP 'lodres: NELEC/NCF/NW does not match' + ) STOP 'lodres: NELEC/NCF/NW does not match' ! ! Read the nuclear parameters ! - READ (IMCDF) Z, EMN - READ (IMCDF) NPARM, (PARM(I),I=1,NPARM) - READ (IMCDF) N, (ZZ(I),I=1,N), NNUC - - IF (N > NNNP) STOP 'lodres: N greater than NNNP' + READ (IMCDF) Z, EMN + READ (IMCDF) NPARM, (PARM(I),I=1,NPARM) + READ (IMCDF) N, (ZZ(I),I=1,N), NNUC + + IF (N > NNNP) STOP 'lodres: N greater than NNNP' ! ! Read the physical effects specifications ! iccutblk() is now an array of length nblock. ! READ (IMCDF) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, WFACT, LVP, & - LNMS, LSMS + LNMS, LSMS ! ! Read the remaining parameters controlling the radial grid and the ! grid arrays ! - NP10 = N + 10 + NP10 = N + 10 READ (IMCDF) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), (RPOR(I),I=1,& - NP10) + NP10) ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Allocate storage for the radial wavefunction arrays ! - CALL ALLOC (PF, NNNP,NW, 'PF', 'LODMIX') - CALL ALLOC (QF, NNNP,NW, 'QF', 'LODMIX') + CALL ALLOC (PF, NNNP,NW, 'PF', 'LODMIX') + CALL ALLOC (QF, NNNP,NW, 'QF', 'LODMIX') ! ! Read the orbital wavefunctions and the associated arrays ! - DO J = 1, NW - READ (IMCDF) E(J), GAMA(J), PZ(J), MF(J) - READ (IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) - END DO + DO J = 1, NW + READ (IMCDF) E(J), GAMA(J), PZ(J), MF(J) + READ (IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + END DO ! ! Determine if the self-energy contribution is to be estimated ! - WRITE (ISTDE, *) 'Estimate contributions from the self-energy?' - LSE = GETYN() + WRITE (ISTDE, *) 'Estimate contributions from the self-energy?' + LSE = GETYN() IF (LSE) THEN WRITE(734,'(a)') 'y ! Estimate contributions from the self-energy?' ELSE WRITE(734,'(a)') 'n ! Estimate contributions from the self-energy?' END IF - - RETURN - END SUBROUTINE LODRES + + RETURN + END SUBROUTINE LODRES diff --git a/src/appl/rci90/lodres_I.f90 b/src/appl/rci90/lodres_I.f90 index e56f23421..b7e055c59 100644 --- a/src/appl/rci90/lodres_I.f90 +++ b/src/appl/rci90/lodres_I.f90 @@ -1,9 +1,9 @@ - MODULE lodres_I + MODULE lodres_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodres - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodres + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/maneig.f90 b/src/appl/rci90/maneig.f90 index fe4e818ec..2a1ee57d6 100644 --- a/src/appl/rci90/maneig.f90 +++ b/src/appl/rci90/maneig.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MANEIG(IATJPO, IASPAR) + SUBROUTINE MANEIG(IATJPO, IASPAR) ! * ! This module manages the operation of the eigensolvers and the * ! storage of the eigenpairs. There are two principal branches: * @@ -40,11 +40,11 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! Block Version By Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE, LONG USE memory_man @@ -54,23 +54,23 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) USE orb_C, ONLY: ncf, nw, iqa USE prnt_C USE where_C - USE WCHBLK_C + USE WCHBLK_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dnicmv_I - USE spicmv2_I - USE spodmv_I - USE posfile_I - USE dinit_I - USE dspevx_I - USE iniestsd_I - USE gdvd_I - USE iniest2_I - USE iniestdm_I - USE itjpo_I - USE ispar_I + USE dnicmv_I + USE spicmv2_I + USE spodmv_I + USE posfile_I + USE dinit_I + USE dspevx_I + USE iniestsd_I + USE gdvd_I + USE iniest2_I + USE iniestdm_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! E x t e r n a l F u n c t i o n s @@ -80,14 +80,14 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: IATJPO - INTEGER, INTENT(OUT) :: IASPAR + INTEGER, INTENT(OUT) :: IATJPO + INTEGER, INTENT(OUT) :: IASPAR !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- -!cjb INTEGER, PARAMETER :: IOLPCK = 1000 - INTEGER, PARAMETER :: IOLPCK = 2000 -! GG REAL(DOUBLE), PARAMETER :: ABSTOL = 1.0D-10 +!cjb INTEGER, PARAMETER :: IOLPCK = 1000 + INTEGER, PARAMETER :: IOLPCK = 2000 +! GG REAL(DOUBLE), PARAMETER :: ABSTOL = 1.0D-10 !cjb NINCOR !cjb INTEGER, PARAMETER :: NINCOR = 1 ! To enforce DISK INTEGER, PARAMETER :: NINCOR = 268435456 ! = 2 GB or memory @@ -98,53 +98,53 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) INTEGER :: MYID, NPROCS, NROWS, I, NDENSE, NCFDUM, ICCUTDUM, MYIDDUM, & NPROCSDUM, IOFSET, NELC, IR, NVECMN, NVEX, M, INFO, LOC, NBRKEV, & IMV, NDENSE_L, LIM, LWORK, LIWORK, MAXITR, MBLOCK, NEND, & - ILOW, IHIGH, NIV, NLOOPS, NMV, IERR, J, IA + ILOW, IHIGH, NIV, NLOOPS, NMV, IERR, J, IA REAL(DOUBLE) :: ELSTO, DUMMY, & DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA, ABSTOL -! GG DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA - LOGICAL :: HIEND, LDISC, SPARSE - CHARACTER(LEN=8) :: CNUM +! GG DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA + LOGICAL :: HIEND, LDISC, SPARSE + CHARACTER(LEN=8) :: CNUM REAL(DOUBLE), DIMENSION(:), pointer :: w, z, work, diag INTEGER, DIMENSION(:), pointer :: iwork, ifail, jwork !----------------------------------------------------------------------- ABSTOL = 2*DLAMCH('S') - MYID = 0 - NPROCS = 1 - !IF (MYID == 0) WRITE (6, *) 'Calling maneig...' - + MYID = 0 + NPROCS = 1 + !IF (MYID == 0) WRITE (6, *) 'Calling maneig...' + ! (nrows+1) is the number of records of the present block's .res file - - NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS - IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) + + NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS + IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) !CALL posfile (1, imcdf, nrows+1) - CALL POSFILE (0, IMCDF, NPOSITION) - - IF (NCF == 1) THEN + CALL POSFILE (0, IMCDF, NPOSITION) + + IF (NCF == 1) THEN !----------------------------------------------------------------------- ! ! (1) - Trivial ncf = 1 ! !------------------------------------------------------- - WRITE (24, *) 'Trivial eigenvalue problem.' - + WRITE (24, *) 'Trivial eigenvalue problem.' + ! Matrix of order 1: the trivial case; we assume that the value ! of EAV is available - - CALL ALLOC (EVAL, 1,'EVAL', 'MANEIG' ) - CALL ALLOC (EVEC, 1, 'EVECO', 'MANEIG') - EVAL(1) = 0.D0 - EVEC(1) = 1.D0 - + + CALL ALLOC (EVAL, 1,'EVAL', 'MANEIG' ) + CALL ALLOC (EVEC, 1, 'EVECO', 'MANEIG') + EVAL(1) = 0.D0 + EVEC(1) = 1.D0 + ! Still read through the .res file !GG !GG Gediminas NIST 2005.11.03 !GG READ (imcdf) - DO I = 1, NROWS + 1 - READ (IMCDF) - END DO - - ELSE !if-2 -!----------------------------------------------------------------------- + DO I = 1, NROWS + 1 + READ (IMCDF) + END DO + + ELSE !if-2 +!----------------------------------------------------------------------- ! ! (2) - Non trivial ! @@ -152,52 +152,52 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! ! Matrix of order greater than 1; how many elements in a triangle? ! - NDENSE = (NCF*(NCF + 1))/2 - - IF (NCF <= IOLPCK) THEN -!----------------------------------------------------------------------- + NDENSE = (NCF*(NCF + 1))/2 + + IF (NCF <= IOLPCK) THEN +!----------------------------------------------------------------------- ! ! (2.1) - LAPACK Dense, Memory, ! !------------------------------------------------------- - IF (MYID == 0) THEN + IF (MYID == 0) THEN WRITE (6, *) & - 'LAPACK routine DSPEVX selected for eigenvalue problem.' + 'LAPACK routine DSPEVX selected for eigenvalue problem.' WRITE (24, *) & - 'LAPACK routine DSPEVX selected for eigenvalue problem.' - ENDIF - + 'LAPACK routine DSPEVX selected for eigenvalue problem.' + ENDIF + ! Allocate storage for the dense representation of the matrix ! and initialize emt - - CALL ALLOC (EMT, NDENSE, 'EMT', 'MANEIG') - CALL DINIT (NDENSE, 0.0D00, EMT, 1) - -! Read the matrix into position from the disc file; it's already + + CALL ALLOC (EMT, NDENSE, 'EMT', 'MANEIG') + CALL DINIT (NDENSE, 0.0D00, EMT, 1) + +! Read the matrix into position from the disc file; it's already ! been properly positioned. - - CALL ALLOC (WORK, NCF,'WORK', 'MANEIG' ) - CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + CALL ALLOC (WORK, NCF,'WORK', 'MANEIG' ) + CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'maneig:1' - - DO I = MYID + 1, NCF, NPROCS - IOFSET = (I*(I - 1))/2 + 'maneig:1' + + DO I = MYID + 1, NCF, NPROCS + IOFSET = (I*(I - 1))/2 READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),IR=1,& - NELC) + NELC) ! In the row-mode of the lower triangle, ! diagonal is the last one - DO IR = 1, NELC - 1 - EMT(IOFSET+IROW(IR)) = WORK(IR) - END DO - EMT(IOFSET+IROW(NELC)) = WORK(NELC) - EAV - - END DO - - CALL DALLOC (WORK, 'WORK', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') - + DO IR = 1, NELC - 1 + EMT(IOFSET+IROW(IR)) = WORK(IR) + END DO + EMT(IOFSET+IROW(NELC)) = WORK(NELC) - EAV + + END DO + + CALL DALLOC (WORK, 'WORK', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') + ! Find the eigenpairs ! ! ivec() - serial numbers of eigenstates of the current block @@ -205,52 +205,52 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! nvecmn - minimum serial number of the eigenstates of the block ! nvecmx - maximum ............. ! nvex - clear from def: NVECMX-NVECMN+1 - - NVECMN = NCF - DO I = 1, NVEC - NVECMN = MIN(NVECMN,IVEC(I)) - END DO - NVEX = NVECMX - NVECMN + 1 - CALL ALLOC (W, NVEX, 'W', 'MANEIG') - CALL ALLOC (Z, NCF*NVEX,'Z', 'MANEIG' ) - CALL ALLOC (WORK, NCF*8,'WORK', 'MANEIG' ) - CALL ALLOC (IWORK, NCF*5,'IWORK', 'MANEIG' ) -! GG CALL ALLOC (IFAIL, NVEX, 'IFAIL', 'MANEIG') - CALL ALLOC (IFAIL, NCF, 'IFAIL', 'MANEIG') + + NVECMN = NCF + DO I = 1, NVEC + NVECMN = MIN(NVECMN,IVEC(I)) + END DO + NVEX = NVECMX - NVECMN + 1 + CALL ALLOC (W, NVEX, 'W', 'MANEIG') + CALL ALLOC (Z, NCF*NVEX,'Z', 'MANEIG' ) + CALL ALLOC (WORK, NCF*8,'WORK', 'MANEIG' ) + CALL ALLOC (IWORK, NCF*5,'IWORK', 'MANEIG' ) +! GG CALL ALLOC (IFAIL, NVEX, 'IFAIL', 'MANEIG') + CALL ALLOC (IFAIL, NCF, 'IFAIL', 'MANEIG') CALL DSPEVX ('V', 'I', 'U', NCF, EMT, DUMMY, DUMMY, NVECMN, NVECMX& - , ABSTOL, M, W, Z, NCF, WORK, IWORK, IFAIL, INFO) - IF (INFO /= 0) STOP 'maneig: Failure in DSPEVX [LAPACK]' - CALL DALLOC (WORK, 'WORK', 'MANEIG') + , ABSTOL, M, W, Z, NCF, WORK, IWORK, IFAIL, INFO) + IF (INFO /= 0) STOP 'maneig: Failure in DSPEVX [LAPACK]' + CALL DALLOC (WORK, 'WORK', 'MANEIG') CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL DALLOC (IFAIL, 'IFAIL', 'MANEIG') - CALL DALLOC (EMT, 'EMT', 'MANEIG') - + CALL DALLOC (IFAIL, 'IFAIL', 'MANEIG') + CALL DALLOC (EMT, 'EMT', 'MANEIG') + ! Store the eigenpairs in their proper positions EVAL() and EVEC() - CALL ALLOC (EVAL, NVEC,'EVAL', 'MANEIG' ) + CALL ALLOC (EVAL, NVEC,'EVAL', 'MANEIG' ) CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG') - DO I = 1, NVEC - LOC = IVEC(I) - EVAL(I) = W(LOC - NVECMN + 1) - IOFSET = NCF*(I - 1) - LOC = NCF*(LOC - NVECMN) - CALL DCOPY (NCF, Z(LOC + 1), 1, EVEC(IOFSET+1), 1) - END DO - CALL DALLOC (W, 'W', 'MANEIG') - CALL DALLOC (Z, 'Z', 'MANEIG') - - ELSE + DO I = 1, NVEC + LOC = IVEC(I) + EVAL(I) = W(LOC - NVECMN + 1) + IOFSET = NCF*(I - 1) + LOC = NCF*(LOC - NVECMN) + CALL DCOPY (NCF, Z(LOC + 1), 1, EVEC(IOFSET+1), 1) + END DO + CALL DALLOC (W, 'W', 'MANEIG') + CALL DALLOC (Z, 'Z', 'MANEIG') + + ELSE !----------------------------------------------------------------------- - + ! (2.2) - DVDSON --- preparation work ! !------------------------------------------------------- - WRITE (24,*)'DVDSON routine selected for eigenvalue problem;' - + WRITE (24,*)'DVDSON routine selected for eigenvalue problem;' + ! Sparse or dense matrix multiply? On disc or in core? - -!GG NBRKEV = (NCF + 1)*(NCF + 1)/3 ! Normal + +!GG NBRKEV = (NCF + 1)*(NCF + 1)/3 ! Normal !NBRKEV = 1 ! To enforce DENSE !NBRKEV = (NCF*(NCF+1)) / 2 + 1 ! To enforde SPARSE !-------------------------------------------------------------- @@ -258,40 +258,40 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! ! !-------------------------------------------------------------- - SPARSE = .TRUE. - NSTORE = NELMNT + NELMNT/2 + (NCF + 1)/2 - - CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIG') - - IF (NSTORE > NINCOR) THEN -!----------------------------------------------------------------------- + SPARSE = .TRUE. + NSTORE = NELMNT + NELMNT/2 + (NCF + 1)/2 + + CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIG') + + IF (NSTORE > NINCOR) THEN +!----------------------------------------------------------------------- ! ! (2.2.1) - DVDSON --- Disk, load diagonal ! !------------------------------------------------------- - WRITE (24, *) ' matrix stored on disc;' - + WRITE (24, *) ' matrix stored on disc;' + ! Disk storage; necessarily sparse; one column of the matrix in ! memory - - LDISC = .TRUE. - SPARSE = .TRUE. - IMV = 1 - + + LDISC = .TRUE. + SPARSE = .TRUE. + IMV = 1 + ! Load diagonal - Each node will have the same, complete copy ! after this if block - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'maneig:2' - - DO I = MYID + 1, NCF, NPROCS - READ (IMCDF) NELC, ELSTO, (DUMMY,IR=2,NELC), DIATMP - DIAG(I) = DIATMP - EAV - END DO - - ELSE -!----------------------------------------------------------------------- + 'maneig:2' + + DO I = MYID + 1, NCF, NPROCS + READ (IMCDF) NELC, ELSTO, (DUMMY,IR=2,NELC), DIATMP + DIAG(I) = DIATMP - EAV + END DO + + ELSE +!----------------------------------------------------------------------- ! ! (2.2.2) - DVDSON --- Memory, load all ! @@ -299,228 +299,228 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! ! Core storage; load matrix into memory ! - LDISC = .FALSE. - IF (SPARSE) THEN -!----------------------------------------------------------------------- - + LDISC = .FALSE. + IF (SPARSE) THEN +!----------------------------------------------------------------------- + ! (2.2.2.1) - DVDSON --- Memory, load all, sparse ! !------------------------------------------------------- IF (MYID == 0) WRITE (24, *) & - ' matrix stored in sparse representation in core;' - - IMV = 2 - WRITE (6, *) 'nelmnt = ', NELMNT - CALL ALLOC (EMT, NELMNT, 'EMT', 'MANEIG') - CALL ALLOC (IROW, NELMNT, 'IROW', 'MANEIG') - CALL ALLOC (IENDC, 0, NCF , 'IENDC', 'MANEIG') - IOFSET = 0 - IENDC(0) = 0 - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + ' matrix stored in sparse representation in core;' + + IMV = 2 + WRITE (6, *) 'nelmnt = ', NELMNT + CALL ALLOC (EMT, NELMNT, 'EMT', 'MANEIG') + CALL ALLOC (IROW, NELMNT, 'IROW', 'MANEIG') + CALL ALLOC (IENDC, 0, NCF , 'IENDC', 'MANEIG') + IOFSET = 0 + IENDC(0) = 0 + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) & - STOP 'maneig:3' - DO I = MYID + 1, NCF, NPROCS + STOP 'maneig:3' + DO I = MYID + 1, NCF, NPROCS READ (IMCDF) NELC, ELSTO, (EMT(IR+IOFSET),IR=1,NELC), (& - IROW(IR + IOFSET),IR=1,NELC) - EMT(NELC+IOFSET) = EMT(NELC+IOFSET) - EAV - DIAG(I) = EMT(NELC+IOFSET) - IOFSET = IOFSET + NELC - IENDC(I) = IOFSET -! WRITE (31 + MYID, *) I, IENDC(I), DIAG(I) - - END DO - ELSE -!----------------------------------------------------------------------- + IROW(IR + IOFSET),IR=1,NELC) + EMT(NELC+IOFSET) = EMT(NELC+IOFSET) - EAV + DIAG(I) = EMT(NELC+IOFSET) + IOFSET = IOFSET + NELC + IENDC(I) = IOFSET +! WRITE (31 + MYID, *) I, IENDC(I), DIAG(I) + + END DO + ELSE +!----------------------------------------------------------------------- ! ! (2.2.2.2) - DVDSON --- Memory, load all, dense ! !------------------------------------------------------- WRITE (24, *) & - ' matrix stored in full representation in core;' - - IMV = 3 - + ' matrix stored in full representation in core;' + + IMV = 3 + ! Find NDENSE_L, the number of elements on the node (dense form) - - NDENSE_L = 0 - DO I = MYID + 1, NCF, NPROCS - NDENSE_L = NDENSE_L + I - END DO - - CALL ALLOC (EMT, NDENSE_L, 'EMT', 'MANEIG') - CALL DINIT (NDENSE_L, 0.0D00, EMT, 1) - CALL ALLOC (WORK, NCF, 'WORK', 'MANEIG') - CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + NDENSE_L = 0 + DO I = MYID + 1, NCF, NPROCS + NDENSE_L = NDENSE_L + I + END DO + + CALL ALLOC (EMT, NDENSE_L, 'EMT', 'MANEIG') + CALL DINIT (NDENSE_L, 0.0D00, EMT, 1) + CALL ALLOC (WORK, NCF, 'WORK', 'MANEIG') + CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) & - STOP 'maneig:4' - - IOFSET = 0 - DO I = MYID + 1, NCF, NPROCS + STOP 'maneig:4' + + IOFSET = 0 + DO I = MYID + 1, NCF, NPROCS READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),& - IR=1,NELC) - WORK(NELC) = WORK(NELC) - EAV - DIAG(I) = WORK(NELC) - DO IR = 1, NELC - EMT(IOFSET+IROW(IR)) = WORK(IR) - END DO - IOFSET = IOFSET + I - END DO - CALL DALLOC (WORK, 'WORK', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') - - ENDIF + IR=1,NELC) + WORK(NELC) = WORK(NELC) - EAV + DIAG(I) = WORK(NELC) + DO IR = 1, NELC + EMT(IOFSET+IROW(IR)) = WORK(IR) + END DO + IOFSET = IOFSET + I + END DO + CALL DALLOC (WORK, 'WORK', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') + + ENDIF ! ...Memory mode - sparse or dense -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! (2.2.2.3e) *** E n d o f D V D S O N m e m o r y -!----------------------------------------------------------------------- - ENDIF +!----------------------------------------------------------------------- + ENDIF ! ...Disk or Memory -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! (2.2.3e) *** E n d o f D V D S O N -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! ! Allocate storage for workspace; see the header of DVDSON for ! the expression below; the value of LIM can be reduced to NVECMX ! plus a smaller number if storage is severely constrained ! - LIM = MIN(NCF,2*NVECMX + 60) + LIM = MIN(NCF,2*NVECMX + 60) ! lwork = 2*ncf*lim + lim*lim + (nvecmx+10)*lim + nvecmx - LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECMX - CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') - LIWORK = 6*LIM + NVECMX - CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') + LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECMX + CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') + LIWORK = 6*LIM + NVECMX + CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') !*changed by Misha 02/12/97 - CRITE = 1.0D-17 - CRITC = 1.0D-09 - CRITR = 1.0D-09 - ORTHO = MAX(1D-9,CRITR) + CRITE = 1.0D-17 + CRITC = 1.0D-09 + CRITR = 1.0D-09 + ORTHO = MAX(1D-9,CRITR) ! end of changes - + ! maxitr = MAX (nvecmx*100, ncf/10) - MAXITR = MAX(NVECMX*200,NCF/10) + MAXITR = MAX(NVECMX*200,NCF/10) !maxitr = MIN (nvect*100, ncf) ! FROM RSCFVU !!! - CALL ALLOC (JWORK, LIM,'JWORK', 'MANEIG' ) - - CALL ALLOC (EVAL, NVECMX, 'EVAL', 'MANEIG') - CALL ALLOC (EVEC, NCF*NVECMX, 'EVEC', 'MANEIG') - - DMUNGO = 10.D99 - CALL DINIT (NVECMX, DMUNGO, EVAL, 1) - + CALL ALLOC (JWORK, LIM,'JWORK', 'MANEIG' ) + + CALL ALLOC (EVAL, NVECMX, 'EVAL', 'MANEIG') + CALL ALLOC (EVEC, NCF*NVECMX, 'EVEC', 'MANEIG') + + DMUNGO = 10.D99 + CALL DINIT (NVECMX, DMUNGO, EVAL, 1) + ! Compute the eigenpairs in each block - - NVEX = NVECMX - IF (LDISC) THEN - MBLOCK = NVEX - ELSE - MBLOCK = 1 - ENDIF - NEND = NCF*NVEX - - ILOW = 1 - IHIGH = NVEX - NIV = NVEX -!************************************************************************ + + NVEX = NVECMX + IF (LDISC) THEN + MBLOCK = NVEX + ELSE + MBLOCK = 1 + ENDIF + NEND = NCF*NVEX + + ILOW = 1 + IHIGH = NVEX + NIV = NVEX +!************************************************************************ ! ! Call Davidson eigensolver ! - SELECT CASE (IMV) - CASE (1) + SELECT CASE (IMV) + CASE (1) !******************** sparse and matrix on disk ********************** - WRITE (6, *) ' Sparse - Disk, iniestsd' - CALL POSFILE (0, IMCDF, NPOSITION)! was within iniestsd before - CALL INIESTSD (2000, NCF, MYID, NPROCS, NIV, WORK, IMCDF, EAV) - + WRITE (6, *) ' Sparse - Disk, iniestsd' + CALL POSFILE (0, IMCDF, NPOSITION)! was within iniestsd before + CALL INIESTSD (2000, NCF, MYID, NPROCS, NIV, WORK, IMCDF, EAV) + !NIV = 0 ! Why equal 0 ??? - !WRITE (6, *) ' Calling gdvd(spodmv,...' + !WRITE (6, *) ' Calling gdvd(spodmv,...' CALL GDVD (SPODMV, NCF, LIM, DIAG, ILOW, IHIGH, JWORK, NIV, & MBLOCK, CRITE, CRITC, CRITR, ORTHO, MAXITR, WORK, LWORK, & - IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) - - CASE (2) + IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) + + CASE (2) !******************** sparse and matrix in memory ******************** - WRITE (6, *) ' Sparse - Memory, iniest2' + WRITE (6, *) ' Sparse - Memory, iniest2' ! CALL INIEST2 (1000, NCF,NIV,WORK,EMT,IENDC,IROW) - CALL INIEST2 (2000, NCF, NIV, WORK, EMT, IENDC, IROW) - !WRITE (*, *) NCF, NIV, (WORK(I),I=NCF*NIV + 1,NCF*NIV + NIV) - !WRITE (*, *) LIM, ILOW, IHIGH, MBLOCK, MAXITR, LWORK, LIWORK - !WRITE (*, *) IERR + CALL INIEST2 (2000, NCF, NIV, WORK, EMT, IENDC, IROW) + !WRITE (*, *) NCF, NIV, (WORK(I),I=NCF*NIV + 1,NCF*NIV + NIV) + !WRITE (*, *) LIM, ILOW, IHIGH, MBLOCK, MAXITR, LWORK, LIWORK + !WRITE (*, *) IERR CALL GDVD (SPICMV2, NCF, LIM, DIAG, ILOW, IHIGH, JWORK, NIV, & MBLOCK, CRITE, CRITC, CRITR, ORTHO, MAXITR, WORK, LWORK, & - IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) - !WRITE (*, *) 'after gdvd...' - !WRITE (*, *) NCF, NIV, (WORK(I),I=NCF*NIV + 1,NCF*NIV + NIV) - !WRITE (*, *) LIM, ILOW, IHIGH, MBLOCK, MAXITR, LWORK, LIWORK - !WRITE (*, *) HIEND, NLOOPS, NMV, IERR - - CALL DALLOC (EMT, 'EMT', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') - CALL DALLOC (IENDC, 'IENDC', 'MANEIG') - - CASE (3) + IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) + !WRITE (*, *) 'after gdvd...' + !WRITE (*, *) NCF, NIV, (WORK(I),I=NCF*NIV + 1,NCF*NIV + NIV) + !WRITE (*, *) LIM, ILOW, IHIGH, MBLOCK, MAXITR, LWORK, LIWORK + !WRITE (*, *) HIEND, NLOOPS, NMV, IERR + + CALL DALLOC (EMT, 'EMT', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') + CALL DALLOC (IENDC, 'IENDC', 'MANEIG') + + CASE (3) !*************************** dense and in memory ********************** - WRITE (6, *) ' Dense - Memory, iniestdm' + WRITE (6, *) ' Dense - Memory, iniestdm' ! CALL INIESTDM (1000,NCF,NIV,WORK,EMT) - CALL INIESTDM (2000, NCF, NIV, WORK, EMT) + CALL INIESTDM (2000, NCF, NIV, WORK, EMT) CALL GDVD (DNICMV, NCF, LIM, DIAG, ILOW, IHIGH, JWORK, NIV, & MBLOCK, CRITE, CRITC, CRITR, ORTHO, MAXITR, WORK, LWORK, & - IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) - CALL DALLOC (EMT, 'EMT', 'MANEIG') - END SELECT -!************************************************************************ - CALL DALLOC (DIAG, 'DIAG', 'MANEIG') - CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL DALLOC (JWORK, 'JWORK', 'MANEIG') - - WRITE (24, *) ' ', NLOOPS, ' iterations;' - WRITE (24, *) ' ', NMV, ' matrix-vector multiplies.' - - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'MANEIG: Returned from DVDSON with' - WRITE (ISTDE, *) ' IERR = ', IERR, '.' - STOP 'maneig: DVDSON wrong' - ENDIF - + IWORK, LIWORK, HIEND, NLOOPS, NMV, IERR) + CALL DALLOC (EMT, 'EMT', 'MANEIG') + END SELECT +!************************************************************************ + CALL DALLOC (DIAG, 'DIAG', 'MANEIG') + CALL DALLOC (IWORK, 'IWORK', 'MANEIG') + CALL DALLOC (JWORK, 'JWORK', 'MANEIG') + + WRITE (24, *) ' ', NLOOPS, ' iterations;' + WRITE (24, *) ' ', NMV, ' matrix-vector multiplies.' + + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'MANEIG: Returned from DVDSON with' + WRITE (ISTDE, *) ' IERR = ', IERR, '.' + STOP 'maneig: DVDSON wrong' + ENDIF + ! Put the eigenpairs in order, overwriting as necessary - - CALL DCOPY (NVEX, WORK(NEND+1), 1, EVAL, 1) - CALL DCOPY (NCF*NVEX, WORK(1), 1, EVEC, 1) - CALL DALLOC (WORK, 'WORK', 'MANEIG') - + + CALL DCOPY (NVEX, WORK(NEND+1), 1, EVAL, 1) + CALL DCOPY (NCF*NVEX, WORK(1), 1, EVEC, 1) + CALL DALLOC (WORK, 'WORK', 'MANEIG') + ! Rearrange and reallocate storage for the eigenpairs ! as necessary - - IF (NVEC < NVECMX) THEN - CALL ALLOC (IWORK, NVECMX, 'IWORK', 'MANEIG') - DO I = 1, NVECMX - IWORK(I) = I - END DO - DO I = 1, NVEC - IOFSET = IVEC(I) - LOC = IWORK(I) - IF (IOFSET == LOC) CYCLE - CALL DSWAP (1, EVAL(IOFSET), 1, EVAL(I), 1) - IWORK(I) = IWORK(IOFSET) - IWORK(IOFSET) = LOC - IOFSET = NCF*(IOFSET - 1) - LOC = NCF*(I - 1) - CALL DSWAP (NCF, EVEC(IOFSET+1), 1, EVEC(LOC+1), 1) - END DO - CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL RALLOC (EVAL, NVEC, 'EVAL', 'MANEIG') - CALL RALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG' ) - - ENDIF - - ENDIF -! (2.3e) *** E N D O F N O N - T R I V I A L C A S E - - ENDIF + + IF (NVEC < NVECMX) THEN + CALL ALLOC (IWORK, NVECMX, 'IWORK', 'MANEIG') + DO I = 1, NVECMX + IWORK(I) = I + END DO + DO I = 1, NVEC + IOFSET = IVEC(I) + LOC = IWORK(I) + IF (IOFSET == LOC) CYCLE + CALL DSWAP (1, EVAL(IOFSET), 1, EVAL(I), 1) + IWORK(I) = IWORK(IOFSET) + IWORK(IOFSET) = LOC + IOFSET = NCF*(IOFSET - 1) + LOC = NCF*(I - 1) + CALL DSWAP (NCF, EVEC(IOFSET+1), 1, EVEC(LOC+1), 1) + END DO + CALL DALLOC (IWORK, 'IWORK', 'MANEIG') + CALL RALLOC (EVAL, NVEC, 'EVAL', 'MANEIG') + CALL RALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG' ) + + ENDIF + + ENDIF +! (2.3e) *** E N D O F N O N - T R I V I A L C A S E + + ENDIF ! (3e) *** E N D O F A L L - + !-------------------------------------------------------------------- ! Only the following quantities are needed after this routine is ! finished: @@ -529,30 +529,30 @@ SUBROUTINE MANEIG(IATJPO, IASPAR) ! ! Clean up eigenvectors; determine their J/P values ! - DO J = 1, NVEC - + DO J = 1, NVEC + ! Find the dominant component of each eigenvector - - IOFSET = (J - 1)*NCF - - AMAX = 0.D0 - DO I = 1, NCF - WA = ABS(EVEC(I+IOFSET)) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO - -! Find the angular momentum and parity of the dominant component - - IATJPO = ITJPO(IA) - IASPAR = ISPAR(IA) - + + IOFSET = (J - 1)*NCF + + AMAX = 0.D0 + DO I = 1, NCF + WA = ABS(EVEC(I+IOFSET)) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO + +! Find the angular momentum and parity of the dominant component + + IATJPO = ITJPO(IA) + IASPAR = ISPAR(IA) + ! Change sign of eigenvactor if dominant component is negative - - IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE - EVEC(1+IOFSET:NCF+IOFSET) = -EVEC(1+IOFSET:NCF+IOFSET) - END DO - - RETURN - END SUBROUTINE MANEIG + + IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE + EVEC(1+IOFSET:NCF+IOFSET) = -EVEC(1+IOFSET:NCF+IOFSET) + END DO + + RETURN + END SUBROUTINE MANEIG diff --git a/src/appl/rci90/maneig_I.f90 b/src/appl/rci90/maneig_I.f90 index 730ad3f19..ea7093d32 100644 --- a/src/appl/rci90/maneig_I.f90 +++ b/src/appl/rci90/maneig_I.f90 @@ -1,11 +1,11 @@ - MODULE maneig_I + MODULE maneig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maneig (IATJPO, IASPAR) - INTEGER, INTENT(OUT) :: IATJPO - INTEGER, INTENT(OUT) :: IASPAR - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE maneig (IATJPO, IASPAR) + INTEGER, INTENT(OUT) :: IATJPO + INTEGER, INTENT(OUT) :: IASPAR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/matrix.f90 b/src/appl/rci90/matrix.f90 index 17c764cfc..b61a85751 100644 --- a/src/appl/rci90/matrix.f90 +++ b/src/appl/rci90/matrix.f90 @@ -16,8 +16,8 @@ SUBROUTINE MATRIX (ncore, j2max) ! Block version Xinghong He Last revision: 12 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -39,10 +39,10 @@ SUBROUTINE MATRIX (ncore, j2max) USE stat_C USE wave_C USE where_C - USE blim_C + USE blim_C USE eigvec1_C !USE blk_C - USE iccu_C + USE iccu_C USE cteilsrk_C USE coeils_C USE bilst_C @@ -75,7 +75,7 @@ SUBROUTINE MATRIX (ncore, j2max) !----------------------------------------------- REAL(DOUBLE), DIMENSION(NNNW) :: slfint CHARACTER(LEN=8) :: CNUM - REAL(DOUBLE) :: atwinv, elsto, eau, ecm, eev, elemnt + REAL(DOUBLE) :: atwinv, elsto, eau, ecm, eev, elemnt REAL(DOUBLE), DIMENSION(:), pointer :: slf_en, ucf, etot INTEGER(LONG) :: nelmnt_a INTEGER :: myid, nprocs, iiatjpo, iiaspar @@ -87,12 +87,12 @@ SUBROUTINE MATRIX (ncore, j2max) !*************************************************************** ! ...Common to all blocks - place here to save CPU time CALL auxblk (j2max, atwinv) - + !*************************************************************** ! Loop over blocks !*************************************************************** ncminpas = 0 - + DO 100 jblock = 1, nblock ncf = ncfblk(jblock) nvec = nevblk(jblock) @@ -103,7 +103,7 @@ SUBROUTINE MATRIX (ncore, j2max) do ic=1,ncf SLF_EN(IC) = 0.0 enddo - + nposition = 7 + nw + nw ! File position of the previous block ! in the .res file DO i = 1, jblock - 1 @@ -111,11 +111,11 @@ SUBROUTINE MATRIX (ncore, j2max) IF (ncfblk(i) .LT. nprocs) j = ncfblk(i) / (myid+1) nposition = nposition + j + 1 ENDDO - + !.. SETHAM does not handle this extrem case IF (nprocs .GT. NCF) & STOP 'matrix: too many nodes' - + ! ...Obtain ivec() from iccmin() IF (nvec .GT. 0) THEN CALL alloc (ivec, nvec, 'IVEC', 'MATRIX') @@ -124,7 +124,7 @@ SUBROUTINE MATRIX (ncore, j2max) ENDDO ncminpas = ncminpas + nvec ENDIF - + ! ...These 3 were allocated in lodcsh2 and deallocated at the end ! ... of this routine and in the setham. In this block version, ! ... both allocation and deallocation are placed here. See the @@ -132,14 +132,14 @@ SUBROUTINE MATRIX (ncore, j2max) CALL ALLOC (IQA, NNNW, ncf, 'IQA', 'MATRIX') CALL ALLOC (JQSA, NNNW, 3, ncf, 'JQSA', 'MATRIX') CALL ALLOC (JCUPA, NNNW, ncf, 'JCUPA', 'MATRIX') - + ! ...Load CSF list of the current block CALL lodcsh2 (21, ncore, jblock) ! zou - + IF (LSE) THEN PRINT *, 'Entering QED ...' - + WRITE (24,*) WRITE (24,*) ' Self Energy Corrections: ' WRITE (24,*) @@ -153,7 +153,7 @@ SUBROUTINE MATRIX (ncore, j2max) ! print *,ic, elemnt SLF_EN(IC) = ELEMNT ENDDO - + WRITE (24,*) WRITE (24,*) 'Self-energy corrections estimated' & //' --- these will influence the data' @@ -195,15 +195,15 @@ SUBROUTINE MATRIX (ncore, j2max) ! added to EAV which was later substracted from H. Thus at ! this point, EAV is correct (it has ELSTO added), EVAL() ! need ELSTO and the correct EAV. - IF (NCF > 1) then + IF (NCF > 1) then DO i = 1, NVEC EVAL(i) = EVAL(i) + ELSTO ENDDO END IF - + CALL ENGOUT (EAV,EVAL,IiATJPO,iIASPAR,IVEC,NVEC,3) CALL WGHTD5 (iiatjpo, iiaspar) - + ! ...Write ASF symmetries, eigenvalues, and eigenvectors to RCI92 ! ...MIXing coefficients File; close the file; print a report WRITE (25) jblock, ncf, nvec, iiatjpo, iiaspar @@ -233,7 +233,7 @@ SUBROUTINE MATRIX (ncore, j2max) IF (.not.LSE) THEN PRINT *, 'Entering QED ...' CALL ALLOC (ETOT,NVEC,'ETOT', 'MATRIX') - + WRITE (24,*) WRITE (24,*) ' Self Energy Corrections: ' WRITE (24,*) @@ -259,7 +259,7 @@ SUBROUTINE MATRIX (ncore, j2max) WRITE (24,302) j,LABJ(IiATJPO),LABP(IP),EAU,ECM,EEV ! ENDDO - + WRITE (24,*) WRITE (24,*) 'Self-energy corrections estimated' & //' --- these do not influence the data' @@ -268,22 +268,22 @@ SUBROUTINE MATRIX (ncore, j2max) ! zou CALL ENGOUT (EAV+elsto,ETOT,IiATJPO,iIASPAR,IVEC,NVEC,MODE) CALL dalloc (ETOT, 'ETOT', 'MATRIX') ENDIF - + ! ...Locals CALL dalloc (ivec, 'IVEC', 'MATRIX') ! ...Allocated in maneig CALL dalloc (eval, 'EVAL', 'MATRIX') CALL dalloc (evec, 'EVEC', 'MATRIX') - + 80 CONTINUE - + ! ...Locals CALL dalloc (IQA, 'IQA', 'MATRIX') CALL dalloc (JQSA, 'JQSA', 'MATRIX') CALL dalloc (JCUPA, 'JCUPA', 'MATRIX') CALL dalloc (SLF_EN, 'SLF_EN', 'MATRIX') CALL dalloc (UCF, 'UCF', 'MATRIX') - + 100 CONTINUE ! ! Close the restart files; nothing will be added to them now @@ -295,7 +295,7 @@ SUBROUTINE MATRIX (ncore, j2max) CALL dalloc (ncmaxblk, 'NCMAXBLK', 'MATRIX') CALL dalloc (iccutblk, 'ICUTTBLK', 'MATRIX') CALL dalloc (iccmin, 'ICCMIN', 'MATRIX') ! allocated in items as pnccmin - + CALL dalloc (VALTEIRK, 'VALTEIRK', 'MATRIX') ! allocated in genintrk CALL dalloc (INDTEIRK, 'INDTEIRK', 'MATRIX') ! allocated in genintrk ! @@ -364,10 +364,10 @@ SUBROUTINE MATRIX (ncore, j2max) CALL DALLOC (VALVPI, 'VALVPI', 'MATRIX') ENDIF ENDIF - + CALL dalloc (PF, 'PF', 'MATRIX') ! lodrwf or lodres CALL dalloc (QF, 'QF', 'MATRIX') ! lodrwf or lodres - + RETURN - + END diff --git a/src/appl/rci90/matrix_I.f90 b/src/appl/rci90/matrix_I.f90 index 3b8bca184..ecf4d6e52 100644 --- a/src/appl/rci90/matrix_I.f90 +++ b/src/appl/rci90/matrix_I.f90 @@ -1,10 +1,10 @@ - MODULE matrix_I + MODULE matrix_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE MATRIX (ncore, j2max) INTEGER, INTENT(IN):: ncore, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/mohr.f90 b/src/appl/rci90/mohr.f90 index 658b969d4..8db7132b6 100644 --- a/src/appl/rci90/mohr.f90 +++ b/src/appl/rci90/mohr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) + SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! * ! The function F (Z*alpha) for the 1s 2s 2p- 2p symmetries * ! is computed here. A value is obtained by interpolating in, or * @@ -12,35 +12,35 @@ SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE interp_I + USE interp_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE) , INTENT(OUT) :: FZALFA + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE) , INTENT(OUT) :: FZALFA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- ! Number of data points - INTEGER, PARAMETER :: NUMVAL = 12 + INTEGER, PARAMETER :: NUMVAL = 12 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE), DIMENSION(NUMVAL) :: VAL1S, VAL2S, VAL2P1, VAL2P3, ARG - REAL(DOUBLE) :: ACCY, VALUE + REAL(DOUBLE), DIMENSION(NUMVAL) :: VAL1S, VAL2S, VAL2P1, VAL2P3, ARG + REAL(DOUBLE) :: ACCY, VALUE !----------------------------------------------- ! ! @@ -48,73 +48,73 @@ SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! DATA VAL1S/ 10.3168D00, 4.6540D00, 3.2460D00, 2.5519D00, 2.1351D00, & 1.8644D00, 1.6838D00, 1.5675D00, 1.5032D00, 1.4880D00, 1.5317D00, & - 1.6614D00/ + 1.6614D00/ ! ! 2s data: ! DATA VAL2S/ 10.5468D00, 4.8930D00, 3.5063D00, 2.8391D00, 2.4550D00, & 2.2244D00, 2.0948D00, 2.0435D00, 2.0650D00, 2.1690D00, 2.3870D00, & - 2.7980D00/ + 2.7980D00/ ! ! 2p- data: ! DATA VAL2P1/ -0.1264D00, -0.1145D00, -0.0922D00, -0.0641D00, -0.0308D00, & 0.0082D00, 0.0549D00, 0.1129D00, 0.1884D00, 0.2934D00, 0.4530D00, & - 0.7250D00/ + 0.7250D00/ ! ! 2p data: ! DATA VAL2P3/ 0.1235D00, 0.1303D00, 0.1436D00, 0.1604D00, 0.1794D00, & 0.1999D00, 0.2215D00, 0.2440D00, 0.2671D00, 0.2906D00, 0.3141D00, & - 0.3367D00/ + 0.3367D00/ ! ! Z data: ! DATA ARG/ 1.0D00, 10.0D00, 20.0D00, 30.0D00, 40.0D00, 50.0D00, 60.0D00, & - 70.0D00, 80.0D00, 90.0D00, 100.0D00, 110.0D00/ + 70.0D00, 80.0D00, 90.0D00, 100.0D00, 110.0D00/ ! !----------------------------------------------------------------------* ! ! Convergence criterion for interpolation ! - DATA ACCY/ 1.0D-03/ + DATA ACCY/ 1.0D-03/ ! ! Interpolate or issue error message as appropriate ! - IF (N == 1) THEN - IF (KAPPA == (-1)) THEN - CALL INTERP (ARG, VAL1S, NUMVAL, Z, VALUE, ACCY) - ELSE - WRITE (*, 300) - WRITE (*, 301) N, KAPPA - STOP - ENDIF - ELSE IF (N == 2) THEN - SELECT CASE (KAPPA) - CASE (-1) - CALL INTERP (ARG, VAL2S, NUMVAL, Z, VALUE, ACCY) - CASE (1) - CALL INTERP (ARG, VAL2P1, NUMVAL, Z, VALUE, ACCY) - CASE (-2) - CALL INTERP (ARG, VAL2P3, NUMVAL, Z, VALUE, ACCY) - CASE DEFAULT - WRITE (*, 300) - WRITE (*, 301) N, KAPPA - STOP - END SELECT - ELSE - WRITE (*, 300) - WRITE (*, 302) N - STOP - ENDIF -! - FZALFA = VALUE -! - RETURN -! - 300 FORMAT('MOHR:') - 301 FORMAT(' Principal quantum number, ',I12,', kappa, ',1I3,'.') - 302 FORMAT(' Principal quantum number, ',1I2,', Should be either 1 or 2.') - RETURN -! - END SUBROUTINE MOHR + IF (N == 1) THEN + IF (KAPPA == (-1)) THEN + CALL INTERP (ARG, VAL1S, NUMVAL, Z, VALUE, ACCY) + ELSE + WRITE (*, 300) + WRITE (*, 301) N, KAPPA + STOP + ENDIF + ELSE IF (N == 2) THEN + SELECT CASE (KAPPA) + CASE (-1) + CALL INTERP (ARG, VAL2S, NUMVAL, Z, VALUE, ACCY) + CASE (1) + CALL INTERP (ARG, VAL2P1, NUMVAL, Z, VALUE, ACCY) + CASE (-2) + CALL INTERP (ARG, VAL2P3, NUMVAL, Z, VALUE, ACCY) + CASE DEFAULT + WRITE (*, 300) + WRITE (*, 301) N, KAPPA + STOP + END SELECT + ELSE + WRITE (*, 300) + WRITE (*, 302) N + STOP + ENDIF +! + FZALFA = VALUE +! + RETURN +! + 300 FORMAT('MOHR:') + 301 FORMAT(' Principal quantum number, ',I12,', kappa, ',1I3,'.') + 302 FORMAT(' Principal quantum number, ',1I2,', Should be either 1 or 2.') + RETURN +! + END SUBROUTINE MOHR diff --git a/src/appl/rci90/mohr_I.f90 b/src/appl/rci90/mohr_I.f90 index cf0be8319..63d6e8e2f 100644 --- a/src/appl/rci90/mohr_I.f90 +++ b/src/appl/rci90/mohr_I.f90 @@ -1,16 +1,16 @@ - MODULE mohr_I + MODULE mohr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mohr (N, KAPPA, Z, FZALFA) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NUMVAL - PARAMETER (NUMVAL = 12) - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE), INTENT(OUT) :: FZALFA - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mohr (N, KAPPA, Z, FZALFA) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NUMVAL + PARAMETER (NUMVAL = 12) + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE), INTENT(OUT) :: FZALFA + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/ncharg.f90 b/src/appl/rci90/ncharg.f90 index 00016485a..d7ecc4b81 100644 --- a/src/appl/rci90/ncharg.f90 +++ b/src/appl/rci90/ncharg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NCHARG + SUBROUTINE NCHARG ! * ! This routine evaluates the nuclear charge density, and stores it * ! in the common array ZDIST . * @@ -10,13 +10,13 @@ SUBROUTINE NCHARG ! Written by Farid A Parpia, at Oxford Last updated: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: pi, z, precis USE grid_C USE npar_C @@ -25,57 +25,57 @@ SUBROUTINE NCHARG !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE es_I + USE es_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I REAL(DOUBLE) :: C, A, CBA, PI2, ABC, ABC2, ABC3, S2MCBA, S3MCBA, EN, & - ZNORM, EXTRM, ZDISTI - LOGICAL :: FORM1, FORM2 + ZNORM, EXTRM, ZDISTI + LOGICAL :: FORM1, FORM2 !----------------------------------------------- ! ! ! Initialize array to zero ! - ZDIST(:N) = 0.0D00 + ZDIST(:N) = 0.0D00 ! ! Fermi charge distribution ! - IF (NPARM == 2) THEN - C = PARM(1) - A = PARM(2) - CBA = C/A - PI2 = PI*PI - ABC = A/C - ABC2 = ABC*ABC - ABC3 = ABC2*ABC - CALL ES ((-CBA), S2MCBA, S3MCBA) - EN = 1.0D00 + PI2*ABC2 - 6.0D00*ABC3*S3MCBA - ZNORM = 3.0D00*Z/(4.0D00*PI*EN*C**3) - FORM1 = .TRUE. - FORM2 = .FALSE. - DO I = 1, N - IF (FORM1) THEN - EXTRM = EXP((R(I)-C)/A) - ZDIST(I) = ZNORM/(1.0D00 + EXTRM) - IF (1.0D00/EXTRM <= PRECIS) THEN - FORM1 = .FALSE. - FORM2 = .TRUE. - ENDIF - ELSE IF (FORM2) THEN - ZDISTI = ZNORM*EXP((-(R(I)-C)/A)) - IF (ABS(ZDISTI) > 0.0D00) THEN - ZDIST(I) = ZDISTI - ELSE - MTP = I - EXIT - ENDIF - ENDIF - END DO - ENDIF + IF (NPARM == 2) THEN + C = PARM(1) + A = PARM(2) + CBA = C/A + PI2 = PI*PI + ABC = A/C + ABC2 = ABC*ABC + ABC3 = ABC2*ABC + CALL ES ((-CBA), S2MCBA, S3MCBA) + EN = 1.0D00 + PI2*ABC2 - 6.0D00*ABC3*S3MCBA + ZNORM = 3.0D00*Z/(4.0D00*PI*EN*C**3) + FORM1 = .TRUE. + FORM2 = .FALSE. + DO I = 1, N + IF (FORM1) THEN + EXTRM = EXP((R(I)-C)/A) + ZDIST(I) = ZNORM/(1.0D00 + EXTRM) + IF (1.0D00/EXTRM <= PRECIS) THEN + FORM1 = .FALSE. + FORM2 = .TRUE. + ENDIF + ELSE IF (FORM2) THEN + ZDISTI = ZNORM*EXP((-(R(I)-C)/A)) + IF (ABS(ZDISTI) > 0.0D00) THEN + ZDIST(I) = ZDISTI + ELSE + MTP = I + EXIT + ENDIF + ENDIF + END DO + ENDIF ! - RETURN + RETURN ! - END SUBROUTINE NCHARG + END SUBROUTINE NCHARG diff --git a/src/appl/rci90/ncharg_I.f90 b/src/appl/rci90/ncharg_I.f90 index 316f869cc..0feb4f532 100644 --- a/src/appl/rci90/ncharg_I.f90 +++ b/src/appl/rci90/ncharg_I.f90 @@ -1,9 +1,9 @@ - MODULE ncharg_I + MODULE ncharg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ncharg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ncharg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/qed.f90 b/src/appl/rci90/qed.f90 index 35982785b..96606a3c8 100644 --- a/src/appl/rci90/qed.f90 +++ b/src/appl/rci90/qed.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QED(JSTATE, SLFINT, UCF) + SUBROUTINE QED(JSTATE, SLFINT, UCF) ! * ! This routine estimates corrections to the energy levels due to * ! self-energy. * @@ -12,13 +12,13 @@ SUBROUTINE QED(JSTATE, SLFINT, UCF) ! Modified by Xinghong He Last update: 24 Jun 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE def_C USE eigv_C @@ -29,97 +29,97 @@ SUBROUTINE QED(JSTATE, SLFINT, UCF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE ratden_I - USE fzalf_I + USE iq_I + USE ratden_I + USE fzalf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JSTATE - REAL(DOUBLE), INTENT(OUT) :: SLFINT(NNNW) - REAL(DOUBLE), INTENT(OUT) :: UCF(1) + INTEGER, INTENT(IN) :: JSTATE + REAL(DOUBLE), INTENT(OUT) :: SLFINT(NNNW) + REAL(DOUBLE), INTENT(OUT) :: UCF(1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MAXITER, J, I, II, NPJ, KAPPA, MFJ - REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP - REAL(DOUBLE) :: UCFJ, ZEFF, RATIO, VALU - CHARACTER :: NPCHAR, NAKCHAR*2 + INTEGER :: MAXITER, J, I, II, NPJ, KAPPA, MFJ + REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP + REAL(DOUBLE) :: UCFJ, ZEFF, RATIO, VALU + CHARACTER :: NPCHAR, NAKCHAR*2 !----------------------------------------------- ! ! Pre-set tolerable number for iteration in finding effective ! nuclear charge. ! - MAXITER = 20 + MAXITER = 20 ! ! Modified so that UCFJ describes the current eigenstate ! - DO J = 1, NW - UCFJ = 0.0D00 + DO J = 1, NW + UCFJ = 0.0D00 ! DO 3 I = 1,NVEC - I = JSTATE - DO II = 1, NCF - UCFJ = UCFJ + DBLE(IQ(J,II))*EVEC(II + (I - 1)*NCF)**2 - END DO + I = JSTATE + DO II = 1, NCF + UCFJ = UCFJ + DBLE(IQ(J,II))*EVEC(II + (I - 1)*NCF)**2 + END DO ! 3 CONTINUE ! print *, ucfj,'ucf' - UCF(J) = UCFJ + UCF(J) = UCFJ ! zou UCF(J) = UCFJ/DBLE (NCF) - END DO + END DO ! - DO J = 1, NW + DO J = 1, NW ! - NPJ = NP(J) + NPJ = NP(J) ! - IF (NPJ <= 8) THEN + IF (NPJ <= 8) THEN ! ! Only orbitals with principal quantum number 8 or less can ! be treated by this section of code ! - KAPPA = NAK(J) + KAPPA = NAK(J) ! ! Begin by transferring the function to a temporary array ! - MFJ = MF(J) + MFJ = MF(J) ! - PTEMP(1) = 0.0D00 - QTEMP(1) = 0.0D00 - DO I = 2, MFJ - PTEMP(I) = PF(I,J) - QTEMP(I) = QF(I,J) - END DO + PTEMP(1) = 0.0D00 + QTEMP(1) = 0.0D00 + DO I = 2, MFJ + PTEMP(I) = PF(I,J) + QTEMP(I) = QF(I,J) + END DO ! - ZEFF = Z - RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) - VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) + ZEFF = Z + RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) + VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) ! - SLFINT(J) = VALU*ZEFF**4/(PI*C**3) + SLFINT(J) = VALU*ZEFF**4/(PI*C**3) ! print *, 'No. orb.=',j,' Zeff = ',zeff ! & , 'Scale= ',ratio ! & , 'S.E. = ',slfint(j)*2*13.6058,slfint(j)/ratio*2*13.6058 ! - ELSE + ELSE ! ! The self-energy for orbitals with principal quantum number ! greater than 8 is set to zero ! - SLFINT(J) = 0.0D00 + SLFINT(J) = 0.0D00 ! - ENDIF + ENDIF ! - END DO + END DO ! ! Deallocate storage for the `generalised occupation numbers' ! ! - RETURN - END SUBROUTINE QED + RETURN + END SUBROUTINE QED !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) ! * ! This subprogram computes the overlap of the orbital tabulated in * ! the arrays P and Q with maximum tabulation point MTPO with * @@ -131,12 +131,12 @@ REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Switches: +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Switches: !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C USE horb_C, ONLY: ph, qh @@ -144,47 +144,47 @@ REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dcbsrw_I - USE quad_I + USE dcbsrw_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE), INTENT(IN) :: P(NNNP) - REAL(DOUBLE), INTENT(IN) :: Q(NNNP) + INTEGER , INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE), INTENT(IN) :: P(NNNP) + REAL(DOUBLE), INTENT(IN) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPH, I, K - REAL(DOUBLE) :: EH, PZH, RESULT, RESULT1 + INTEGER :: MTPH, I, K + REAL(DOUBLE) :: EH, PZH, RESULT, RESULT1 !----------------------------------------------- ! ! ! ! Set up the hydrogenic orbital ! - CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) + CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) ! ! Compute the overlap ! - MTP = MIN(MTPH,MTPO) - DO I = 2, MTP - IF (RP(I) > 0.0219) CYCLE - K = I - END DO - MTP = K - TA(1) = 0.0D00 - TA(2:MTP) = (P(2:MTP)*P(2:MTP)+Q(2:MTP)*Q(2:MTP))*RP(2:MTP) + MTP = MIN(MTPH,MTPO) + DO I = 2, MTP + IF (RP(I) > 0.0219) CYCLE + K = I + END DO + MTP = K + TA(1) = 0.0D00 + TA(2:MTP) = (P(2:MTP)*P(2:MTP)+Q(2:MTP)*Q(2:MTP))*RP(2:MTP) ! TA(I) = (P(I)*PH(I)+Q(I)*QH(I))*RP(I) - CALL QUAD (RESULT) - TA(2:MTP) = (PH(2:MTP)*PH(2:MTP)+QH(2:MTP)*QH(2:MTP))*RP(2:MTP) - CALL QUAD (RESULT1) + CALL QUAD (RESULT) + TA(2:MTP) = (PH(2:MTP)*PH(2:MTP)+QH(2:MTP)*QH(2:MTP))*RP(2:MTP) + CALL QUAD (RESULT1) ! - RATDEN = RESULT/RESULT1 + RATDEN = RESULT/RESULT1 ! - RETURN - END FUNCTION RATDEN + RETURN + END FUNCTION RATDEN diff --git a/src/appl/rci90/qed_I.f90 b/src/appl/rci90/qed_I.f90 index f39d01a36..f618f4106 100644 --- a/src/appl/rci90/qed_I.f90 +++ b/src/appl/rci90/qed_I.f90 @@ -1,14 +1,14 @@ - MODULE qed_I + MODULE qed_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qed (JSTATE, SLFINT, UCF) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE qed (JSTATE, SLFINT, UCF) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - INTEGER, INTENT(IN) :: JSTATE - REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT - REAL(DOUBLE), DIMENSION(1), INTENT(OUT) :: UCF - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: JSTATE + REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT + REAL(DOUBLE), DIMENSION(1), INTENT(OUT) :: UCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/qed_slfen.f90 b/src/appl/rci90/qed_slfen.f90 index 229d6dbfd..d47bfbc07 100644 --- a/src/appl/rci90/qed_slfen.f90 +++ b/src/appl/rci90/qed_slfen.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QED_SLFEN(SLFINT) + SUBROUTINE QED_SLFEN(SLFINT) ! * ! This routine estimates the F(Z\alpha) function of self energy for * ! each orbital. * @@ -11,13 +11,13 @@ SUBROUTINE QED_SLFEN(SLFINT) ! Modified from subroutine QED by Yu Zou, Last update: 13 Mar 2000 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE def_C USE eigv_C @@ -29,8 +29,8 @@ SUBROUTINE QED_SLFEN(SLFINT) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ratden_I - USE fzalf_I + USE ratden_I + USE fzalf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -40,16 +40,16 @@ SUBROUTINE QED_SLFEN(SLFINT) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: MAXITER, J, NPJ, KAPPA, MFJ, I, NPJMAX -!GG REAL(DOUBLE), DIMENSION(1) :: UCF - REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP - REAL(DOUBLE) :: ZEFF, RATIO, VALU - CHARACTER :: NPCHAR, NAKCHAR*2 +!GG REAL(DOUBLE), DIMENSION(1) :: UCF + REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP + REAL(DOUBLE) :: ZEFF, RATIO, VALU + CHARACTER :: NPCHAR, NAKCHAR*2 !----------------------------------------------- ! ! Pre-set tolerable number for iteration in finding effective ! nuclear charge. ! - MAXITER = 20 + MAXITER = 20 !Per IF (NQEDCUT.EQ.1) THEN NPJMAX = NQEDMAX @@ -58,45 +58,45 @@ SUBROUTINE QED_SLFEN(SLFINT) END IF !Per ! - DO J = 1, NW + DO J = 1, NW ! - NPJ = NP(J) + NPJ = NP(J) ! - IF (NPJ <= NPJMAX) THEN + IF (NPJ <= NPJMAX) THEN ! ! Only orbitals with principal quantum number 8 or less can ! be treated by this section of code ! - KAPPA = NAK(J) + KAPPA = NAK(J) ! ! Begin by transferring the function to a temporary array ! - MFJ = MF(J) + MFJ = MF(J) ! - PTEMP(1) = 0.0D00 - QTEMP(1) = 0.0D00 - DO I = 2, MFJ - PTEMP(I) = PF(I,J) - QTEMP(I) = QF(I,J) - END DO - ZEFF = Z - RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) - VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) - SLFINT(J) = VALU*ZEFF**4/(PI*C**3) + PTEMP(1) = 0.0D00 + QTEMP(1) = 0.0D00 + DO I = 2, MFJ + PTEMP(I) = PF(I,J) + QTEMP(I) = QF(I,J) + END DO + ZEFF = Z + RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) + VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) + SLFINT(J) = VALU*ZEFF**4/(PI*C**3) ! - ELSE + ELSE ! ! The self-energy for orbitals with principal quantum number ! greater than 8 is set to zero ! - SLFINT(J) = 0.0D00 + SLFINT(J) = 0.0D00 ! - ENDIF + ENDIF ! - END DO + END DO ! ! Deallocate storage for the `generalised occupation numbers' ! ! - RETURN - END SUBROUTINE QED_SLFEN + RETURN + END SUBROUTINE QED_SLFEN diff --git a/src/appl/rci90/qed_slfen_I.f90 b/src/appl/rci90/qed_slfen_I.f90 index 069e3641a..fdaad9677 100644 --- a/src/appl/rci90/qed_slfen_I.f90 +++ b/src/appl/rci90/qed_slfen_I.f90 @@ -1,12 +1,12 @@ - MODULE qed_slfen_I + MODULE qed_slfen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qed_slfen (SLFINT) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE qed_slfen (SLFINT) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/ratden_I.f90 b/src/appl/rci90/ratden_I.f90 index be82c7a1b..0eb26ea58 100644 --- a/src/appl/rci90/ratden_I.f90 +++ b/src/appl/rci90/ratden_I.f90 @@ -1,17 +1,17 @@ - MODULE ratden_I + MODULE ratden_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION ratden (P, Q, MTPO, NP, KAPPA, Z) - USE vast_kind_param, ONLY: DOUBLE + REAL(KIND(0.0D0)) FUNCTION ratden (P, Q, MTPO, NP, KAPPA, Z) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/rci92.f90 b/src/appl/rci90/rci92.f90 index ec8f3abfd..c11d068d8 100644 --- a/src/appl/rci90/rci92.f90 +++ b/src/appl/rci90/rci92.f90 @@ -23,7 +23,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM RCI92 + PROGRAM RCI92 ! * ! Entry routine for RCI92. Controls the entire computation. * ! * @@ -37,11 +37,11 @@ PROGRAM RCI92 ! Modified by Gediminas Gaigalas for new spin-angular integration. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE default_C USE blim_C @@ -57,40 +57,40 @@ PROGRAM RCI92 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setcsl_I - USE setres_I - USE setmix_I - USE strsum_I - USE factt_I - USE matrix_I + USE getyn_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setcsl_I + USE setres_I + USE setmix_I + USE strsum_I + USE factt_I + USE matrix_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NBLK0 = 50 + INTEGER, PARAMETER :: NBLK0 = 50 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER, PARAMETER :: nblk=50 - INTEGER :: NCOUNT1, NCOUNT2, NCOUNT_RATE, NCOUNT_MAX - INTEGER, DIMENSION(8) :: NYMDUHMSM - INTEGER :: MYID, NPROCS, K, LENNAME, NCORE, NDUM, J2MAX, NSECONDS - LOGICAL :: YES - CHARACTER(LEN=128) :: NAME, TMPDIR, PERMDIR, ISOFILE - CHARACTER(LEN=8), DIMENSION(NBLK0) :: IDBLK - CHARACTER :: CHDATE*8, CHTIME*10, CHZONE*5, STR*8, MSG*128 + INTEGER :: NCOUNT1, NCOUNT2, NCOUNT_RATE, NCOUNT_MAX + INTEGER, DIMENSION(8) :: NYMDUHMSM + INTEGER :: MYID, NPROCS, K, LENNAME, NCORE, NDUM, J2MAX, NSECONDS + LOGICAL :: YES + CHARACTER(LEN=128) :: NAME, TMPDIR, PERMDIR, ISOFILE + CHARACTER(LEN=8), DIMENSION(NBLK0) :: IDBLK + CHARACTER :: CHDATE*8, CHTIME*10, CHZONE*5, STR*8, MSG*128 !----------------------------------------------- ! - - IMCDF = 26 ! Unit for rci.res file - IPRERUN = 0 - MYID = 0 - NPROCS = 1 + + IMCDF = 26 ! Unit for rci.res file + IPRERUN = 0 + MYID = 0 + NPROCS = 1 write(*,*) write(*,*) 'RCI' @@ -100,7 +100,7 @@ PROGRAM RCI92 write(*,*) ' rci.res (can be used for restart)' write(*,*) - + ! ! Start timing ! @@ -108,90 +108,90 @@ PROGRAM RCI92 ! ! Get NDEF ! -! WRITE (ISTDE, *) 'RCI2: Execution begins ...' -! WRITE (ISTDE, *) - WRITE (ISTDE, '(A)') 'Default settings? ' - YES = GETYN() - IF (YES) THEN - NDEF = 0 - ELSE - NDEF = 1 - ENDIF +! WRITE (ISTDE, *) 'RCI2: Execution begins ...' +! WRITE (ISTDE, *) + WRITE (ISTDE, '(A)') 'Default settings? ' + YES = GETYN() + IF (YES) THEN + NDEF = 0 + ELSE + NDEF = 1 + ENDIF ! ! Get name of the state (used in files like .c, .s) ! - DO WHILE(.TRUE.) - WRITE (ISTDE, '(A)') 'Name of state: ' - READ (*, '(A)') NAME - K = INDEX(NAME,' ') - IF (K > 1) EXIT - WRITE (ISTDE, *) 'Name may not start with a blank. redo...' - END DO + DO WHILE(.TRUE.) + WRITE (ISTDE, '(A)') 'Name of state: ' + READ (*, '(A)') NAME + K = INDEX(NAME,' ') + IF (K > 1) EXIT + WRITE (ISTDE, *) 'Name may not start with a blank. redo...' + END DO ! Now the name of the state is known, open the log file open(unit=734, file=trim(name)//'.clog',status='unknown') write(734,'(a)') 'y ! Default settings' write(734,'(a)') trim(name) - + ! ...Form the full name of the files used on node-0 - - LENNAME = LEN_TRIM(NAME) - ISOFILE = 'isodata' -! WRITE (6, *) 'isofile = ', ISOFILE(1:LEN_TRIM(ISOFILE)) -! WRITE (6, *) 'name = ', NAME(1:LEN_TRIM(NAME)) - 99 CONTINUE - + LENNAME = LEN_TRIM(NAME) + ISOFILE = 'isodata' +! WRITE (6, *) 'isofile = ', ISOFILE(1:LEN_TRIM(ISOFILE)) +! WRITE (6, *) 'name = ', NAME(1:LEN_TRIM(NAME)) + + 99 CONTINUE + ! ! In SETDBG of this version all control logicals are set to ! false thus no debug output will be made ! -! WRITE (6, *) 'Calling SETDBG...' - CALL SETDBG +! WRITE (6, *) 'Calling SETDBG...' + CALL SETDBG ! ! Perform machine- and installation-dependent setup ! -! WRITE (6, *) 'Calling SETMC...' - CALL SETMC +! WRITE (6, *) 'Calling SETMC...' + CALL SETMC ! ! Set up the physical constants ! -! WRITE (6, *) 'Calling SETCON...' - CALL SETCON +! WRITE (6, *) 'Calling SETCON...' + CALL SETCON ! ! Open summary file ! -! WRITE (6, *) 'Calling SETSUM...' - CALL SETSUM (NAME) - -! WRITE (6, *) 'Calling setcsl...' - CALL SETCSL (NAME(1:LENNAME)//'.c', NCORE, NBLK0, IDBLK) +! WRITE (6, *) 'Calling SETSUM...' + CALL SETSUM (NAME) + +! WRITE (6, *) 'Calling setcsl...' + CALL SETCSL (NAME(1:LENNAME)//'.c', NCORE, NBLK0, IDBLK) ! ! Set up the .res file; determine if this is a restart. ! -! WRITE (6, *) 'Calling SETRES...' - CALL SETRES (ISOFILE, NAME(1:LENNAME)//'.w', IDBLK) +! WRITE (6, *) 'Calling SETRES...' + CALL SETRES (ISOFILE, NAME(1:LENNAME)//'.w', IDBLK) ! ! Open the .mix file; determine the eigenpairs required ! -! WRITE (6, *) 'Calling SETMIX...' - CALL SETMIX (NAME, IDBLK) +! WRITE (6, *) 'Calling SETMIX...' + CALL SETMIX (NAME, IDBLK) ! ! Append a summary of the inputs to the .sum file ! - WRITE (6, *) 'Calling STRSUM...' - CALL STRSUM + WRITE (6, *) 'Calling STRSUM...' + CALL STRSUM ! ! Set up the table of logarithms of factorials ! - WRITE (6, *) 'Calling FACTT...' - CALL FACTT + WRITE (6, *) 'Calling FACTT...' + CALL FACTT ! ! Calculate all the needed Rk integrals ! - WRITE (6, *) 'Calling GENINTRK...' - CALL GENINTRK (MYID, NPROCS, NDUM, J2MAX) + WRITE (6, *) 'Calling GENINTRK...' + CALL GENINTRK (MYID, NPROCS, NDUM, J2MAX) ! ! If transverse interaction comput Breit integrals of type 1 and 2 ! @@ -204,38 +204,38 @@ PROGRAM RCI92 ! ! Proceed with the CI calculation ! - WRITE (6, *) 'Calling MATRIX...' - - CALL MATRIX (NCORE, J2MAX) - - IF (IPRERUN == 1) THEN - IPRERUN = 2 - GO TO 99 - ENDIF - - IF (MYID == 0) THEN - WRITE (6, *) - WRITE (6, *) - WRITE (6, *) 'Finish time, Statistics' - WRITE (6, *) - ENDIF + WRITE (6, *) 'Calling MATRIX...' + + CALL MATRIX (NCORE, J2MAX) + + IF (IPRERUN == 1) THEN + IPRERUN = 2 + GO TO 99 + ENDIF + + IF (MYID == 0) THEN + WRITE (6, *) + WRITE (6, *) + WRITE (6, *) 'Finish time, Statistics' + WRITE (6, *) + ENDIF close(734) - CALL STOPTIME (ncount1, 'RCI') -! CALL SYSTEM_CLOCK (NCOUNT2, NCOUNT_RATE, NCOUNT_MAX) -! NCOUNT2 = NCOUNT2 - NCOUNT1 -! NSECONDS = NCOUNT2/NCOUNT_RATE -! WRITE (STR, '(I8)') NSECONDS -! MSG = STR//' seconds ' -! WRITE (6, *) MSG -! -! CALL DATE_AND_TIME (CHDATE, CHTIME, CHZONE, NYMDUHMSM) -! -! MSG = ' Date: '//CHDATE//' Time: '//CHTIME//' Zone: '//CHZONE -! WRITE (6, *) MSG + CALL STOPTIME (ncount1, 'RCI') +! CALL SYSTEM_CLOCK (NCOUNT2, NCOUNT_RATE, NCOUNT_MAX) +! NCOUNT2 = NCOUNT2 - NCOUNT1 +! NSECONDS = NCOUNT2/NCOUNT_RATE +! WRITE (STR, '(I8)') NSECONDS +! MSG = STR//' seconds ' +! WRITE (6, *) MSG +! +! CALL DATE_AND_TIME (CHDATE, CHTIME, CHZONE, NYMDUHMSM) +! +! MSG = ' Date: '//CHDATE//' Time: '//CHTIME//' Zone: '//CHZONE +! WRITE (6, *) MSG ! ! Print completion message ! -! WRITE (6, *) 'RCI2: Execution complete.' +! WRITE (6, *) 'RCI2: Execution complete.' ! - STOP - END PROGRAM RCI92 + STOP + END PROGRAM RCI92 diff --git a/src/appl/rci90/rkint.f90 b/src/appl/rci90/rkint.f90 index 450d7634f..518e2534b 100644 --- a/src/appl/rci90/rkint.f90 +++ b/src/appl/rci90/rkint.f90 @@ -12,13 +12,13 @@ REAL(KIND(0.0D0)) FUNCTION RKINT (RAC, IA, IC, RBD, IB, ID, K, IW) ! Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE bess_C USE debug_C @@ -29,65 +29,65 @@ REAL(KIND(0.0D0)) FUNCTION RKINT (RAC, IA, IC, RBD, IB, ID, K, IW) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE zkf_I - USE quad_I + USE zkf_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IA, IC - INTEGER, INTENT(IN) :: IB, ID - INTEGER :: K - INTEGER, INTENT(IN) :: IW + INTEGER :: IA, IC + INTEGER, INTENT(IN) :: IB, ID + INTEGER :: K + INTEGER, INTENT(IN) :: IW REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRBD, MXRAC, I - REAL(DOUBLE) :: RESULT + INTEGER :: MXRBD, MXRAC, I + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! MXRBD = MIN (MF(IB),MF(ID)) MXRAC = MIN (MF(IA),MF(IC)) ! - IF (IW == 0) THEN + IF (IW == 0) THEN ! ! IW = 0 ! - TA(:MXRAC) = RAC(:MXRAC) - MTP = MXRAC - CALL ZKF (K, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 - TA(2:MTP) = RBD(2:MTP)*TB(2:MTP)*RPOR(2:MTP) + TA(:MXRAC) = RAC(:MXRAC) + MTP = MXRAC + CALL ZKF (K, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 + TA(2:MTP) = RBD(2:MTP)*TB(2:MTP)*RPOR(2:MTP) ! - ELSE + ELSE ! ! IW = 1,2 ! - TA(:MXRAC) = RAC(:MXRAC)*(1.0D00 + BESSJ(1,IW,:MXRAC)) - MTP = MXRAC - CALL ZKF (K, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 + TA(:MXRAC) = RAC(:MXRAC)*(1.0D00 + BESSJ(1,IW,:MXRAC)) + MTP = MXRAC + CALL ZKF (K, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 TA(2:MTP) = RBD(2:MTP)*(1.0D00 + BESSN(1,IW,2:MTP))*TB(2:MTP)*RPOR(2:& - MTP) + MTP) ! - ENDIF + ENDIF ! - CALL QUAD (RESULT) - RKINT = RESULT + CALL QUAD (RESULT) + RKINT = RESULT ! ! Debug printout if option set ! IF (LDBPR(11)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IC), NH(IC), NP(IB)& - , NH(IB), NP(ID), NH(ID), IW, RESULT + , NH(IB), NP(ID), NH(ID), IW, RESULT ! - RETURN + RETURN ! 300 FORMAT('_ (',1I2,')'/,'R (',1I2,1A2,',',1I2,1A2,'|',1I2,1A2,',',1I2,& - 1A2,';',1I2,') = ',1P,D19.12) - RETURN + 1A2,';',1I2,') = ',1P,D19.12) + RETURN ! - END FUNCTION RKINT + END FUNCTION RKINT diff --git a/src/appl/rci90/rkint_I.f90 b/src/appl/rci90/rkint_I.f90 index 13b298338..034da1e9f 100644 --- a/src/appl/rci90/rkint_I.f90 +++ b/src/appl/rci90/rkint_I.f90 @@ -1,19 +1,19 @@ - MODULE rkint_I + MODULE rkint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION rkint (RAC, IA, IC, RBD, IB, ID, K, IW) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IW - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IW + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/rkintc.f90 b/src/appl/rci90/rkintc.f90 index cbe115471..baece258e 100644 --- a/src/appl/rci90/rkintc.f90 +++ b/src/appl/rci90/rkintc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) + SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) ! * ! k * ! This routine returns R (abcd) integrals. * @@ -8,13 +8,13 @@ SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE cteilsrk_C USE orb_C USE kkstart_C @@ -25,82 +25,82 @@ SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IA, IB, IC, ID - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(OUT) :: TEGRAL + INTEGER, INTENT(INOUT) :: IA, IB, IC, ID + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(OUT) :: TEGRAL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KEY, ISWAP, INDEX, JL, JU, JM, LOC - LOGICAL :: FOUND, FIRST + INTEGER :: KEY, ISWAP, INDEX, JL, JU, JM, LOC + LOGICAL :: FOUND, FIRST !----------------------------------------------- ! - KEY = NW + 1 + KEY = NW + 1 ! ! Ensure that the indices are in `canonical' order ! Compute the composite (packed) index ! - - - IF (IA > IC) THEN - ISWAP = IC - IC = IA - IA = ISWAP - ENDIF - IF (IB > ID) THEN - ISWAP = ID - ID = IB - IB = ISWAP - ENDIF - IF (IA > IB) THEN - ISWAP = IB - IB = IA - IA = ISWAP - ISWAP = ID - ID = IC - IC = ISWAP - ENDIF - - INDEX = ((IA*KEY + IB)*KEY + IC)*KEY + ID + + + IF (IA > IC) THEN + ISWAP = IC + IC = IA + IA = ISWAP + ENDIF + IF (IB > ID) THEN + ISWAP = ID + ID = IB + IB = ISWAP + ENDIF + IF (IA > IB) THEN + ISWAP = IB + IB = IA + IA = ISWAP + ISWAP = ID + ID = IC + IC = ISWAP + ENDIF + + INDEX = ((IA*KEY + IB)*KEY + IC)*KEY + ID ! - JL = KSTART(K) - JU = KSTART(K+1) - 1 - - IF (INDEXINDTEIRK(JU)) THEN - WRITE (*, *) 'Something wrong in rkintc' - STOP - ENDIF + JL = KSTART(K) + JU = KSTART(K+1) - 1 + + IF (INDEXINDTEIRK(JU)) THEN + WRITE (*, *) 'Something wrong in rkintc' + STOP + ENDIF ! ! The index is within the range of the indices stored; search ! for it in the list of indices ! - 1 CONTINUE - IF (JU - JL > 1) THEN - JM = (JU + JL)/2 - IF (INDTEIRK(JM) > INDEX) THEN - JU = JM - ELSE - JL = JM - ENDIF - GO TO 1 - ENDIF + 1 CONTINUE + IF (JU - JL > 1) THEN + JM = (JU + JL)/2 + IF (INDTEIRK(JM) > INDEX) THEN + JU = JM + ELSE + JL = JM + ENDIF + GO TO 1 + ENDIF ! ! The range is bracketed to the extent possible ! - IF (INDEX == INDTEIRK(JU)) THEN - LOC = JU - ELSE IF (INDEX == INDTEIRK(JL)) THEN - LOC = JL - ELSE - WRITE (*, *) K, IA, IB, IC, ID, INDEX - WRITE (*, *) 'Rkintc Integral not found' - STOP - ENDIF + IF (INDEX == INDTEIRK(JU)) THEN + LOC = JU + ELSE IF (INDEX == INDTEIRK(JL)) THEN + LOC = JL + ELSE + WRITE (*, *) K, IA, IB, IC, ID, INDEX + WRITE (*, *) 'Rkintc Integral not found' + STOP + ENDIF ! ! Return the value of the integral ! from storage - - TEGRAL = VALTEIRK(LOC) + + TEGRAL = VALTEIRK(LOC) ! - RETURN - END SUBROUTINE RKINTC + RETURN + END SUBROUTINE RKINTC diff --git a/src/appl/rci90/rkintc_I.f90 b/src/appl/rci90/rkintc_I.f90 index 42484fa5e..0acefa33b 100644 --- a/src/appl/rci90/rkintc_I.f90 +++ b/src/appl/rci90/rkintc_I.f90 @@ -1,18 +1,18 @@ - MODULE rkintc_I + MODULE rkintc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE rkintc (IA, IB, IC, ID, K, TEGRAL) - USE vast_kind_param,ONLY: DOUBLE -! INTEGER KMAX -! PARAMETER (KMAX = 20) - INTEGER, INTENT(INOUT) :: IA - INTEGER, INTENT(INOUT) :: IB - INTEGER, INTENT(INOUT) :: IC - INTEGER, INTENT(INOUT) :: ID - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(OUT) :: TEGRAL - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE rkintc (IA, IB, IC, ID, K, TEGRAL) + USE vast_kind_param,ONLY: DOUBLE +! INTEGER KMAX +! PARAMETER (KMAX = 20) + INTEGER, INTENT(INOUT) :: IA + INTEGER, INTENT(INOUT) :: IB + INTEGER, INTENT(INOUT) :: IC + INTEGER, INTENT(INOUT) :: ID + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(OUT) :: TEGRAL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/setcsl.f90 b/src/appl/rci90/setcsl.f90 index f73cbec13..bcadb5880 100644 --- a/src/appl/rci90/setcsl.f90 +++ b/src/appl/rci90/setcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE SETCSL(NAME, NCORE, NBLKIN, IDBLK) + SUBROUTINE SETCSL(NAME, NCORE, NBLKIN, IDBLK) ! ! A container which calls setcsll to open, read .c file to get ! nblock, ncfblk(), idblk(), ncf (it is ncftot here). @@ -11,11 +11,11 @@ SUBROUTINE SETCSL(NAME, NCORE, NBLKIN, IDBLK) ! Xinghong He 98-06-23 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man USE hblock_C @@ -24,34 +24,34 @@ SUBROUTINE SETCSL(NAME, NCORE, NBLKIN, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- -! USE setcsll_I - USE lodcsh_I +! USE setcsll_I + USE lodcsh_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - INTEGER :: NBLKIN - CHARACTER :: NAME*(*) - CHARACTER(LEN=8), DIMENSION(*) :: IDBLK + INTEGER :: NCORE + INTEGER :: NBLKIN + CHARACTER :: NAME*(*) + CHARACTER(LEN=8), DIMENSION(*) :: IDBLK !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM + INTEGER :: IQADUM !----------------------------------------------- ! ! POINTER (ncfblk, ncfblk(0:*)) !----------------------------------------------------------------------- - - CALL ALLOC (NCFBLK, 0, NBLKIN, 'NCFBLK', 'SETCSL' ) - CALL SETCSLL (21, NAME, NBLKIN, NBLOCK, NCFBLK(1), NCFTOT, IDBLK) - CALL RALLOC (NCFBLK, 0, NBLOCK, 'NCFBLK', 'SETCSL' ) - - REWIND (21) - READ (21, *) - + + CALL ALLOC (NCFBLK, 0, NBLKIN, 'NCFBLK', 'SETCSL' ) + CALL SETCSLL (21, NAME, NBLKIN, NBLOCK, NCFBLK(1), NCFTOT, IDBLK) + CALL RALLOC (NCFBLK, 0, NBLOCK, 'NCFBLK', 'SETCSL' ) + + REWIND (21) + READ (21, *) + !..Load header of .c file - CALL LODCSH (21, NCORE) - - RETURN - END SUBROUTINE SETCSL + CALL LODCSH (21, NCORE) + + RETURN + END SUBROUTINE SETCSL diff --git a/src/appl/rci90/setcsl_I.f90 b/src/appl/rci90/setcsl_I.f90 index ca195ebd9..dba1a7712 100644 --- a/src/appl/rci90/setcsl_I.f90 +++ b/src/appl/rci90/setcsl_I.f90 @@ -1,13 +1,13 @@ - MODULE setcsl_I + MODULE setcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsl (NAME, NCORE, NBLKIN, IDBLK) - CHARACTER (LEN = *) :: NAME - INTEGER :: NCORE - INTEGER, INTENT(IN) :: NBLKIN - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcsl (NAME, NCORE, NBLKIN, IDBLK) + CHARACTER (LEN = *) :: NAME + INTEGER :: NCORE + INTEGER, INTENT(IN) :: NBLKIN + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/setdbg.f90 b/src/appl/rci90/setdbg.f90 index 2c923b5f0..18f8b2728 100644 --- a/src/appl/rci90/setdbg.f90 +++ b/src/appl/rci90/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG + SUBROUTINE SETDBG ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -9,17 +9,17 @@ SUBROUTINE SETDBG ! Written by Farid A Parpia Last update: 21 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- USE debug_C IMPLICIT NONE ! - LDBPA = .FALSE. - LDBPG = .FALSE. - - LDBPR = .FALSE. - - RETURN - END SUBROUTINE SETDBG + LDBPA = .FALSE. + LDBPG = .FALSE. + + LDBPR = .FALSE. + + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rci90/setdbg_I.f90 b/src/appl/rci90/setdbg_I.f90 index 5cd21e293..1b7cb7142 100644 --- a/src/appl/rci90/setdbg_I.f90 +++ b/src/appl/rci90/setdbg_I.f90 @@ -1,9 +1,9 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setdbg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/setham_gg.f90 b/src/appl/rci90/setham_gg.f90 index 083e3bbeb..7fc41db50 100644 --- a/src/appl/rci90/setham_gg.f90 +++ b/src/appl/rci90/setham_gg.f90 @@ -15,8 +15,8 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! Block version by Xinghong He Last revision: 15 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -85,19 +85,19 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & REAL(DOUBLE), DIMENSION(NNNW) :: tshell REAL(DOUBLE) :: tgrl1, tgrl2, tegral - + INTEGER, PARAMETER :: KEY = KEYORB ! ! Matrix elements smaller than CUTOFF are not accumulated ! -!cjb cutoff is use associated and cannot be redeclared +!cjb cutoff is use associated and cannot be redeclared ! REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-20 !cjb CUTOFF = 1.0D-12 below !cjb INTEGER :: ipi, ipj, inc1, inc2, kt, ipt, incor, ncoec, nctec, & i, j, nmcbp, ncore, ic, nelc, irstart, ir, ia, ib, & itype, nctei, iia - REAL(DOUBLE) :: elemnt, precoeff, tcoeff, vcoeff, contr + REAL(DOUBLE) :: elemnt, precoeff, tcoeff, vcoeff, contr !----------------------------------------------------------------------- PRINT *, 'Calling setham ...' !cjb @@ -109,7 +109,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & !Per Bug fix 30/4-2013 ATWINV = 1.D0/EMN !Per Bug fix 30/4-2013 - + IF (IPRERUN .EQ. 2) THEN DO IPI = 1,NVEC DO IPJ = 1,NCF @@ -122,7 +122,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! used for the Coulomb and transverse two-electron integrals ! CALL ALCBUF (1) - + ! ...Locals CALL alloc (emt, ncf, 'EMT','SETHAM' ) CALL alloc (irow, ncf, 'IROW', 'SETHAM') @@ -137,13 +137,13 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & IPT = 1 ! INCOR = 1 - + NCOEC = 0 ! NCTEC = 0 - + IF (LTRANS) THEN - + ! ...Initialisations for transverse interaction correction DO 2 I = 1, NW ICORE(I) = 0 @@ -152,30 +152,30 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ENDDO ICORE(I) = 1 2 CONTINUE - + NMCBP = 0 NCORE = 0 ENDIF - + ! Loop over rows of the Hamiltonian matrix - distributed - + DO 10 ic = icstrt, ncf, nprocs - + NELC = 0 ! counter - Number of non-zeros of this row - + ! Loop over columns of the current row - + irstart = 1 DO 85 IR = irstart, IC - + ! PER IF (LFORDR .AND. (IR .GT. ICCUT(1))) THEN IF (IR.NE.IC) CYCLE END IF ! PER - + ELEMNT = 0.D0 ! accumulates various contributions to H - + ! ! Generate the integral list for the matrix element of the ! one-body operators @@ -187,7 +187,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & INC1 = 1 ENDIF ENDIF - + IF (IPRERUN .EQ. 2) THEN ! ! Diagonal elements are always included @@ -209,10 +209,10 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & IF (PRECOEFF .GT. COEFFCUT2) INC2 = 1 ENDDO ENDIF - + ! ...INC1.EQ.1 ------------> IF (INC1 .EQ. 1) THEN !inc1 is always 1 without PRE-RUN - CALL ONESCALAR(IC,IR,IA,IB,TSHELL) + CALL ONESCALAR(IC,IR,IA,IB,TSHELL) ! ! Accumulate the contribution from the one-body operators: ! kinetic energy, electron-nucleus interaction; update the @@ -291,7 +291,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & 7 CONTINUE ! IBUG1 = 0 - + ENDIF !inc1 is always 1 without PRE-RUN ! ...INC1.EQ.1 <------------ !*********************************************************************** @@ -400,11 +400,11 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! Deallocate storage for the arrays in /BUFFER/ ! CALL ALCBUF (3) - + ! ...Locals CALL DALLOC (EMT, 'EMT', 'SETHAM') CALL DALLOC (IROW, 'IROW', 'SETHAM') - + ! Fill the common block /setham_to_genmat2/ for use in genmat2 CUTOFFtmp = CUTOFF @@ -420,6 +420,6 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & NVINTItmp = NVINTI NELMNTtmp = NELMNT NCFtmp = NCF - + RETURN END SUBROUTINE SETHAM diff --git a/src/appl/rci90/setham_gg_I.f90 b/src/appl/rci90/setham_gg_I.f90 index dbb0c22dd..de01501c8 100644 --- a/src/appl/rci90/setham_gg_I.f90 +++ b/src/appl/rci90/setham_gg_I.f90 @@ -1,7 +1,7 @@ MODULE setham_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & atwinv,slf_en) @@ -14,4 +14,3 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & END SUBROUTINE SETHAM END INTERFACE END MODULE - diff --git a/src/appl/rci90/setham_to_genmat2_C.f90 b/src/appl/rci90/setham_to_genmat2_C.f90 index a7549fc07..3ebdd3a7b 100644 --- a/src/appl/rci90/setham_to_genmat2_C.f90 +++ b/src/appl/rci90/setham_to_genmat2_C.f90 @@ -1,10 +1,10 @@ - MODULE setham_to_genmat2_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE setham_to_genmat2_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(6) :: NTPITMP + INTEGER, DIMENSION(6) :: NTPITMP INTEGER :: NCOEITMP, NCOECTMP, NCTEITMP, NCTECTMP, NMCBPTMP, NCORETMP, & - NVPITMP, NKEITMP, NVINTITMP, NELMNTTMP, NCFTMP - REAL(DOUBLE) :: CUTOFFTMP - END MODULE setham_to_genmat2_C + NVPITMP, NKEITMP, NVINTITMP, NELMNTTMP, NCFTMP + REAL(DOUBLE) :: CUTOFFTMP + END MODULE setham_to_genmat2_C diff --git a/src/appl/rci90/setmix.f90 b/src/appl/rci90/setmix.f90 index 2cb806f17..1ce9e4e3e 100644 --- a/src/appl/rci90/setmix.f90 +++ b/src/appl/rci90/setmix.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETMIX(NAME, IDBLK) + SUBROUTINE SETMIX(NAME, IDBLK) ! * ! Opens the .mix file on stream 25; writes a header to this file; * ! calls LODMIX to interactively determine the eigenpairs required. * @@ -12,42 +12,42 @@ SUBROUTINE SETMIX(NAME, IDBLK) ! Modified by Xinghong He Last revision: 23 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodmix_I + USE openfl_I + USE lodmix_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER(LEN=*) , INTENT(IN) :: NAME - CHARACTER(LEN=8), DIMENSION(*) :: IDBLK + CHARACTER(LEN=*) , INTENT(IN) :: NAME + CHARACTER(LEN=8), DIMENSION(*) :: IDBLK !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' - CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' + CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' + CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR -!----------------------------------------------- - - K = INDEX(NAME,' ') - CALL OPENFL (25, NAME(1:K-1)//'.cm', FORM, STATUS, IERR) - IF (IERR /= 0) STOP 'setmix: Error when opening .cm file' - - WRITE (25) 'G92MIX' - - CALL LODMIX (IDBLK) - - RETURN - END SUBROUTINE SETMIX + INTEGER :: K, IERR +!----------------------------------------------- + + K = INDEX(NAME,' ') + CALL OPENFL (25, NAME(1:K-1)//'.cm', FORM, STATUS, IERR) + IF (IERR /= 0) STOP 'setmix: Error when opening .cm file' + + WRITE (25) 'G92MIX' + + CALL LODMIX (IDBLK) + + RETURN + END SUBROUTINE SETMIX diff --git a/src/appl/rci90/setmix_I.f90 b/src/appl/rci90/setmix_I.f90 index 372c2e72e..ef62d18e6 100644 --- a/src/appl/rci90/setmix_I.f90 +++ b/src/appl/rci90/setmix_I.f90 @@ -1,11 +1,11 @@ - MODULE setmix_I + MODULE setmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmix (NAME, IDBLK) - CHARACTER (LEN = *), INTENT(IN) :: NAME - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmix (NAME, IDBLK) + CHARACTER (LEN = *), INTENT(IN) :: NAME + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/setres.f90 b/src/appl/rci90/setres.f90 index 2deff6ddd..ccf8176d8 100644 --- a/src/appl/rci90/setres.f90 +++ b/src/appl/rci90/setres.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) + SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! * ! Open, check, load data from the .res file. * ! * @@ -10,11 +10,11 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! Modified by Xinghong Last revision: 23 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man USE default_C @@ -25,43 +25,43 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I - USE lodres_I - USE getcid_I + USE getyn_I + USE openfl_I + USE lodres_I + USE getcid_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: ISOFILE*(*) - CHARACTER :: RWFFILE*(*) + CHARACTER :: ISOFILE*(*) + CHARACTER :: RWFFILE*(*) CHARACTER(LEN=8), DIMENSION(*) :: IDBLK !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' - CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' - CHARACTER*6, PARAMETER :: RESTITLE = 'R92RES' + CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' + CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' + CHARACTER*6, PARAMETER :: RESTITLE = 'R92RES' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS - LOGICAL :: FOUND, RESTRT - CHARACTER :: R92RES*6, DEFNAM*11, IDSTRING*3 + INTEGER :: IERR, IOS + LOGICAL :: FOUND, RESTRT + CHARACTER :: R92RES*6, DEFNAM*11, IDSTRING*3 !----------------------------------------------- ! ! Compose the "rci.res" file name ! - DEFNAM = 'rci.res' + DEFNAM = 'rci.res' ! ! Ask if this is a restart ! - IF (NDEF /= 0) THEN - WRITE (ISTDE, *) 'Restarting RCI90 ?' - RESTRT = GETYN() - ELSE - RESTRT = .FALSE. - ENDIF + IF (NDEF /= 0) THEN + WRITE (ISTDE, *) 'Restarting RCI90 ?' + RESTRT = GETYN() + ELSE + RESTRT = .FALSE. + ENDIF ! IF (RESTRT) THEN ! WRITE(734,'(a)') 'y ! Restarting RCI90 ?' ! ELSE @@ -70,42 +70,42 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! ! Do some settings and checks ! - IF (RESTRT) THEN + IF (RESTRT) THEN ! ...Restart, make sure file exist - INQUIRE(FILE=DEFNAM, EXIST=FOUND) - IF (.NOT.FOUND) STOP 'setres: .res does not exist' - ENDIF + INQUIRE(FILE=DEFNAM, EXIST=FOUND) + IF (.NOT.FOUND) STOP 'setres: .res does not exist' + ENDIF ! ! Open the .res file ! - CALL OPENFL (IMCDF, DEFNAM, FORM, STATUS, IERR) - IF (IERR /= 0) STOP 'setres: Error openning .res file' + CALL OPENFL (IMCDF, DEFNAM, FORM, STATUS, IERR) + IF (IERR /= 0) STOP 'setres: Error openning .res file' ! ! If restart, load the contents. Otherwise generate them via getcid ! ! But first of all, iccutblk() is needed in both cases ! - CALL ALLOC (ICCUTBLK, NBLOCK, 'ICCUTBLK', 'SETRES') - - IF (RESTRT) THEN + CALL ALLOC (ICCUTBLK, NBLOCK, 'ICCUTBLK', 'SETRES') + + IF (RESTRT) THEN ! ...Check the signature of the file - READ (IMCDF, IOSTAT=IOS) R92RES - IF (IOS/=0 .OR. R92RES/=RESTITLE) THEN - CLOSE(IMCDF) - STOP 'setres: Not RCI92 .res file' - ENDIF - + READ (IMCDF, IOSTAT=IOS) R92RES + IF (IOS/=0 .OR. R92RES/=RESTITLE) THEN + CLOSE(IMCDF) + STOP 'setres: Not RCI92 .res file' + ENDIF + ! ...Read and check restart information - CALL LODRES - - ELSE - + CALL LODRES + + ELSE + ! ...Write the file header ! ...Generate the first part of the .res file - WRITE (IMCDF) RESTITLE - CALL GETCID (ISOFILE, RWFFILE, IDBLK) - - ENDIF - - RETURN - END SUBROUTINE SETRES + WRITE (IMCDF) RESTITLE + CALL GETCID (ISOFILE, RWFFILE, IDBLK) + + ENDIF + + RETURN + END SUBROUTINE SETRES diff --git a/src/appl/rci90/setres_I.f90 b/src/appl/rci90/setres_I.f90 index 905dcc83c..3ac43ede3 100644 --- a/src/appl/rci90/setres_I.f90 +++ b/src/appl/rci90/setres_I.f90 @@ -1,12 +1,12 @@ - MODULE setres_I + MODULE setres_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setres (ISOFILE, RWFFILE, IDBLK) - CHARACTER (LEN = *) :: ISOFILE - CHARACTER (LEN = *) :: RWFFILE - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setres (ISOFILE, RWFFILE, IDBLK) + CHARACTER (LEN = *) :: ISOFILE + CHARACTER (LEN = *) :: RWFFILE + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/setsum.f90 b/src/appl/rci90/setsum.f90 index 56c586a47..d30ab9bf7 100644 --- a/src/appl/rci90/setsum.f90 +++ b/src/appl/rci90/setsum.f90 @@ -1,32 +1,32 @@ !*********************************************************************** - - SUBROUTINE SETSUM(NAME) + + SUBROUTINE SETSUM(NAME) ! ! Open the .csum file on stream 24. ! Xinghong He 10 Jun 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER(LEN=*) , INTENT(IN) :: NAME + CHARACTER(LEN=*) , INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR + INTEGER :: K, IERR !----------------------------------------------------------------------- - - K = INDEX(NAME,' ') - - CALL OPENFL (24, NAME(1:K-1)//'.csum', 'FORMATTED', 'UNKNOWN', IERR) - - RETURN - END SUBROUTINE SETSUM + + K = INDEX(NAME,' ') + + CALL OPENFL (24, NAME(1:K-1)//'.csum', 'FORMATTED', 'UNKNOWN', IERR) + + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rci90/setsum_I.f90 b/src/appl/rci90/setsum_I.f90 index a80e1be1c..e980ab956 100644 --- a/src/appl/rci90/setsum_I.f90 +++ b/src/appl/rci90/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (NAME) - CHARACTER (LEN = *), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (NAME) + CHARACTER (LEN = *), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/shield.f90 b/src/appl/rci90/shield.f90 index a485d6a4d..412a2e3c6 100644 --- a/src/appl/rci90/shield.f90 +++ b/src/appl/rci90/shield.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION SHIELD (J) + REAL(KIND(0.0D0)) FUNCTION SHIELD (J) ! * ! This routine estimates the screening (or shielding) for orbital * ! J according to the relativistic hydrogenic energy formula. * @@ -19,48 +19,48 @@ REAL(KIND(0.0D0)) FUNCTION SHIELD (J) ! ensure that the self-energy for such orbital is zero. * ! Reference: M J Seaton, Rep. Prog. Phys., Vol.46, P167,1983 * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: A, AA, BB, CC, T, BETA + REAL(DOUBLE) :: A, AA, BB, CC, T, BETA !----------------------------------------------- ! ! ! a=[(1+\alpha^2 E)^{-2} - 1]^{-1/2} ! note E(J) = -E(n,k) - A = 1 - E(J)/(C*C) - A = 1/(A*A) - 1 - IF (A < 0.0) THEN - SHIELD = -C - RETURN - ENDIF - A = 1/SQRT(A) + A = 1 - E(J)/(C*C) + A = 1/(A*A) - 1 + IF (A < 0.0) THEN + SHIELD = -C + RETURN + ENDIF + A = 1/SQRT(A) ! - AA = 1 + A*A - BB = A*DBLE(NP(J)-IABS(NAK(J))) - CC = DBLE((NP(J)-IABS(NAK(J)))**2-NAK(J)**2) - T = BB*BB - AA*CC - IF (T < 0.0) THEN - SHIELD = -C - RETURN - ENDIF - BETA = BB + SQRT(T) - BETA = BETA/AA - SHIELD = Z - BETA*C + AA = 1 + A*A + BB = A*DBLE(NP(J)-IABS(NAK(J))) + CC = DBLE((NP(J)-IABS(NAK(J)))**2-NAK(J)**2) + T = BB*BB - AA*CC + IF (T < 0.0) THEN + SHIELD = -C + RETURN + ENDIF + BETA = BB + SQRT(T) + BETA = BETA/AA + SHIELD = Z - BETA*C ! print *, j, ' Initial Screen Factor = ',shield - RETURN - END FUNCTION SHIELD + RETURN + END FUNCTION SHIELD diff --git a/src/appl/rci90/shield_I.f90 b/src/appl/rci90/shield_I.f90 index 87cda248c..b597fb130 100644 --- a/src/appl/rci90/shield_I.f90 +++ b/src/appl/rci90/shield_I.f90 @@ -1,10 +1,10 @@ - MODULE shield_I + MODULE shield_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION shield (J) - INTEGER, INTENT(IN) :: J - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION shield (J) + INTEGER, INTENT(IN) :: J + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/skint.f90 b/src/appl/rci90/skint.f90 index 14af35f66..6d3b833dc 100644 --- a/src/appl/rci90/skint.f90 +++ b/src/appl/rci90/skint.f90 @@ -14,13 +14,13 @@ REAL(KIND(0.0D0)) FUNCTION SKINT (RAC, IA, IC, RBD, IB, ID, K, IW) ! Last update: 06 Nov 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE bess_C USE debug_C @@ -31,86 +31,86 @@ REAL(KIND(0.0D0)) FUNCTION SKINT (RAC, IA, IC, RBD, IB, ID, K, IW) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE zkf_I - USE quad_I + USE zkf_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IA, IB, IC, ID - INTEGER, INTENT(IN) :: K, IW + INTEGER :: IA, IB, IC, ID + INTEGER, INTENT(IN) :: K, IW REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRAC, MXRBD, I - REAL(DOUBLE), DIMENSION(NNNP) :: TKEEP - REAL(DOUBLE) :: EPSI, W, WK, VALU + INTEGER :: MXRAC, MXRBD, I + REAL(DOUBLE), DIMENSION(NNNP) :: TKEEP + REAL(DOUBLE) :: EPSI, W, WK, VALU !----------------------------------------------- ! ! - EPSI = 1.0D-10 + EPSI = 1.0D-10 ! - W = WIJ(IW) - WK = DBLE(K + K + 1) - MXRAC = MIN(MF(IA),MF(IC)) - MXRBD = MIN(MF(IB),MF(ID)) + W = WIJ(IW) + WK = DBLE(K + K + 1) + MXRAC = MIN(MF(IA),MF(IC)) + MXRBD = MIN(MF(IB),MF(ID)) ! ! (k-1) ! Compute Z (rho ; s) ! ac ! - TA(:MXRAC) = RAC(:MXRAC) - MTP = MXRAC - CALL ZKF (K - 1, IA, IC) + TA(:MXRAC) = RAC(:MXRAC) + MTP = MXRAC + CALL ZKF (K - 1, IA, IC) ! - IF (ABS(W) < EPSI) THEN + IF (ABS(W) < EPSI) THEN ! ! W = 0 case ! - TKEEP(:MTP) = TB(:MTP) - CALL ZKF (K + 1, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 - TA(2:MTP) = RBD(2:MTP)*RPOR(2:MTP)*(TB(2:MTP)-TKEEP(2:MTP)) - CALL QUAD (VALU) - SKINT = WK*VALU*0.5D00 + TKEEP(:MTP) = TB(:MTP) + CALL ZKF (K + 1, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 + TA(2:MTP) = RBD(2:MTP)*RPOR(2:MTP)*(TB(2:MTP)-TKEEP(2:MTP)) + CALL QUAD (VALU) + SKINT = WK*VALU*0.5D00 ! - ELSE + ELSE ! ! Finite w: see I P Grant and B J McKenzie, J Phys B: At Mol Phys, ! 13 (1980) 2671-2681 ! - TKEEP(:MTP) = TB(:MTP) - TA(:MTP) = -TA(:MTP)*BESSJ(1,IW,:MTP) - CALL ZKF (K - 1, IA, IC) + TKEEP(:MTP) = TB(:MTP) + TA(:MTP) = -TA(:MTP)*BESSJ(1,IW,:MTP) + CALL ZKF (K - 1, IA, IC) ! - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 TA(2:MTP) = ((1.0D00 + BESSN(2,IW,2:MTP))*TB(2:MTP)-TKEEP(2:MTP)*BESSN& - (2,IW,2:MTP))*RBD(2:MTP)/R(2:MTP)**2*RPOR(2:MTP) - CALL QUAD (VALU) - SKINT = (WK/W)**2*VALU - TA(:MXRBD) = RBD(:MXRBD)*(1.0D00 + BESSJ(2,IW,:MXRBD)) - MTP = MXRBD - CALL ZKF (K + 1, IB, ID) - MTP = MIN(MTP,MXRAC) - TA(1) = 0.0D00 + (2,IW,2:MTP))*RBD(2:MTP)/R(2:MTP)**2*RPOR(2:MTP) + CALL QUAD (VALU) + SKINT = (WK/W)**2*VALU + TA(:MXRBD) = RBD(:MXRBD)*(1.0D00 + BESSJ(2,IW,:MXRBD)) + MTP = MXRBD + CALL ZKF (K + 1, IB, ID) + MTP = MIN(MTP,MXRAC) + TA(1) = 0.0D00 TA(2:MTP) = RAC(2:MTP)*(1.0D00 + BESSN(1,IW,2:MTP))*TB(2:MTP)*R(2:MTP)& - *RP(2:MTP) - CALL QUAD (VALU) - SKINT = SKINT - VALU*W*W/DBLE((2*K + 3)*(2*K - 1)) + *RP(2:MTP) + CALL QUAD (VALU) + SKINT = SKINT - VALU*W*W/DBLE((2*K + 3)*(2*K - 1)) ! - ENDIF + ENDIF ! IF (LDBPR(11)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IC), NH(IC), NP(IB)& - , NH(IB), NP(ID), NH(ID), IW, VALU + , NH(IB), NP(ID), NH(ID), IW, VALU ! - RETURN + RETURN ! 300 FORMAT(' (',1I2,')'/,'S (',1I2,1A2,',',1I2,1A2,'|',1I2,1A2,',',1I2,& - 1A2,';',1I2,') = ',1P,D19.12) - RETURN + 1A2,';',1I2,') = ',1P,D19.12) + RETURN ! - END FUNCTION SKINT + END FUNCTION SKINT diff --git a/src/appl/rci90/skint_I.f90 b/src/appl/rci90/skint_I.f90 index 9449ba232..67c5d0462 100644 --- a/src/appl/rci90/skint_I.f90 +++ b/src/appl/rci90/skint_I.f90 @@ -1,19 +1,19 @@ - MODULE skint_I + MODULE skint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION skint (RAC, IA, IC, RBD, IB, ID, K, IW) - USE vast_kind_param,ONLY: DOUBLE + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IW - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IW + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/spodmv.f90 b/src/appl/rci90/spodmv.f90 index 6a9180a64..737617314 100644 --- a/src/appl/rci90/spodmv.f90 +++ b/src/appl/rci90/spodmv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SPODMV(N, M, B, C) + SUBROUTINE SPODMV(N, M, B, C) ! * ! Matrix-matrix product: C = AB. A sparse representation of the * ! lower triangle of the (NxN) matrix A is read from the disk * @@ -15,72 +15,72 @@ SUBROUTINE SPODMV(N, M, B, C) ! Block Version by Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE eigv_C USE Where_C USE fposition_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dinit_I - USE posfile_I - USE dmerge_I + USE dinit_I + USE posfile_I + USE dmerge_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(N) :: IROW + INTEGER, DIMENSION(N) :: IROW INTEGER :: MYID, NPROCS, NCF, NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM, ICOL& - , NELC, IR, IV - REAL(DOUBLE), DIMENSION(N) :: EMT - REAL(DOUBLE) :: ELSTO, DIAG, DL + , NELC, IR, IV + REAL(DOUBLE), DIMENSION(N) :: EMT + REAL(DOUBLE) :: ELSTO, DIAG, DL !----------------------------------------------- ! ! !...nposition+1 is the current position of the .res file ! !...It is set in matrix and used in maneig, spodmv ! !----------------------------------------------------------------------- - WRITE (6, *) 'Calling spodmv...' - MYID = 0 - NPROCS = 1 - NCF = N - + WRITE (6, *) 'Calling spodmv...' + MYID = 0 + NPROCS = 1 + NCF = N + ! Initialise the result matrix; note that this is specific to the ! data structure of DVDSON - - CALL DINIT (N*M, 0.D0, C, 1) - + + CALL DINIT (N*M, 0.D0, C, 1) + !...moved from maneig before "CALL GDVD (SPODMV..." - CALL POSFILE (0, IMCDF, NPOSITION) - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + CALL POSFILE (0, IMCDF, NPOSITION) + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'spodmv: ncf read wrong' - - - DO ICOL = MYID + 1, N, NPROCS - READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) - DO IV = 1, M - DIAG = C(ICOL,IV) + (EMT(NELC)-EAV)*B(ICOL,IV) + 'spodmv: ncf read wrong' + + + DO ICOL = MYID + 1, N, NPROCS + READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) + DO IV = 1, M + DIAG = C(ICOL,IV) + (EMT(NELC)-EAV)*B(ICOL,IV) CALL DMERGE (NELC - 1, B(1,IV), C(1,IV), IROW(1), EMT(1), B(ICOL,IV& - ), DL) - C(ICOL,IV) = DIAG + DL - END DO - END DO - - - RETURN - END SUBROUTINE SPODMV + ), DL) + C(ICOL,IV) = DIAG + DL + END DO + END DO + + + RETURN + END SUBROUTINE SPODMV diff --git a/src/appl/rci90/spodmv_I.f90 b/src/appl/rci90/spodmv_I.f90 index 787a7d862..af9f606a6 100644 --- a/src/appl/rci90/spodmv_I.f90 +++ b/src/appl/rci90/spodmv_I.f90 @@ -1,14 +1,14 @@ - MODULE spodmv_I + MODULE spodmv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spodmv (N, M, B, C) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE spodmv (N, M, B, C) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/strsum.f90 b/src/appl/rci90/strsum.f90 index ff8863977..dff448cb2 100644 --- a/src/appl/rci90/strsum.f90 +++ b/src/appl/rci90/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * ! Generates the first part of grasp92.sum (on stream 24). * ! * @@ -10,13 +10,13 @@ SUBROUTINE STRSUM ! Modified by Xinghong He Last revision: 22 Dec 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE Use decide_C USE def_C USE grid_C @@ -32,158 +32,158 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt2_I + USE convrt2_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, NB, ICCUT, I, IEND, IBEG - CHARACTER :: RECORD*256, CDATA*26, CLEVEL*2 + INTEGER :: LENTH, NB, ICCUT, I, IEND, IBEG + CHARACTER :: RECORD*256, CDATA*26, CLEVEL*2 !----------------------------------------------- ! POINTER (pncfblk, ncfblk(0:*)) ! ! POINTER (piccutblk, iccutblk(1)) - + ! ! Get the date and time of day; make this information the ! header of the summary file ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT2 (NELEC, RECORD, LENTH, 'strsum.nelec') - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT2 (NCF, RECORD, LENTH, 'strsum.ncf') - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT2 (NW, RECORD, LENTH, 'strsum.nw') - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT2 (NELEC, RECORD, LENTH, 'strsum.nelec') + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT2 (NCF, RECORD, LENTH, 'strsum.ncf') + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT2 (NW, RECORD, LENTH, 'strsum.nw') + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (LFORDR) THEN - WRITE (24, *) - DO NB = 1, NBLOCK - ICCUT = ICCUTBLK(NB) - CALL CONVRT2 (ICCUT, RECORD, LENTH, 'strsum.icccut') + IF (LFORDR) THEN + WRITE (24, *) + DO NB = 1, NBLOCK + ICCUT = ICCUTBLK(NB) + CALL CONVRT2 (ICCUT, RECORD, LENTH, 'strsum.icccut') WRITE (24, *) ' CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space; nb = ', NB, ' ncf = ', NCFBLK(NB) - END DO - ENDIF + ' the zero-order space; nb = ', NB, ' ncf = ', NCFBLK(NB) + END DO + ENDIF ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z - IF (EMN == 0.0D00) THEN - WRITE (24, *) ' the nucleus is stationary;' - ELSE - WRITE (24, 301) EMN - ENDIF - IF (NPARM == 2) THEN - WRITE (24, *) ' Fermi nucleus:' - WRITE (24, 302) PARM(1), PARM(2) - CALL CONVRT2 (NNUC, RECORD, LENTH, 'strsum.nnuc') + WRITE (24, *) + WRITE (24, 300) Z + IF (EMN == 0.0D00) THEN + WRITE (24, *) ' the nucleus is stationary;' + ELSE + WRITE (24, 301) EMN + ENDIF + IF (NPARM == 2) THEN + WRITE (24, *) ' Fermi nucleus:' + WRITE (24, 302) PARM(1), PARM(2) + CALL CONVRT2 (NNUC, RECORD, LENTH, 'strsum.nnuc') WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 303) C -! - WRITE (24, *) - IF (LTRANS .OR. LVP .OR. LNMS .OR. LSMS) THEN - WRITE (24, *) 'To H (Dirac Coulomb) is added' - IF (LTRANS) WRITE (24, 304) WFACT - IF (LVP) WRITE (24, *) ' H (Vacuum Polarisation);' - IF (LNMS) WRITE (24, *) ' H (Normal Mass Shift);' - IF (LSMS) WRITE (24, *) ' H (Specific Mass Shift);' - WRITE (24, *) ' the total will be diagonalised.' - ELSE - WRITE (24, *) 'H (Dirac Coulomb) will be diagonalised by itself.' - ENDIF -! - IF (LSE) THEN + WRITE (24, *) + WRITE (24, 303) C +! + WRITE (24, *) + IF (LTRANS .OR. LVP .OR. LNMS .OR. LSMS) THEN + WRITE (24, *) 'To H (Dirac Coulomb) is added' + IF (LTRANS) WRITE (24, 304) WFACT + IF (LVP) WRITE (24, *) ' H (Vacuum Polarisation);' + IF (LNMS) WRITE (24, *) ' H (Normal Mass Shift);' + IF (LSMS) WRITE (24, *) ' H (Specific Mass Shift);' + WRITE (24, *) ' the total will be diagonalised.' + ELSE + WRITE (24, *) 'H (Dirac Coulomb) will be diagonalised by itself.' + ENDIF +! + IF (LSE) THEN WRITE (24, *) & - 'Diagonal contributions from H (Self Energy) will be estimated' - WRITE (24, *) ' from a screened hydrogenic approximation.' - ENDIF + 'Diagonal contributions from H (Self Energy) will be estimated' + WRITE (24, *) ' from a screened hydrogenic approximation.' + ENDIF ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.0D00) THEN - WRITE (24, 305) RNT, H, N - ELSE - WRITE (24, 306) RNT, H, HP, N - ENDIF - WRITE (24, 307) R(1), R(2), R(N) + WRITE (24, *) + IF (HP == 0.0D00) THEN + WRITE (24, 305) RNT, H, N + ELSE + WRITE (24, 306) RNT, H, HP, N + ENDIF + WRITE (24, 307) R(1), R(2), R(N) ! ! Write out the orbital properties ! - WRITE (24, *) - WRITE (24, *) 'Subshell radial wavefunction summary:' - WRITE (24, *) - WRITE (24, 308) - WRITE (24, *) - DO I = 1, NW + WRITE (24, *) + WRITE (24, *) 'Subshell radial wavefunction summary:' + WRITE (24, *) + WRITE (24, 308) + WRITE (24, *) + DO I = 1, NW WRITE (24, 309) NP(I), NH(I), E(I), PZ(I), GAMA(I), PF(2,I), QF(2,I), & - MF(I) - END DO + MF(I) + END DO ! ! Write the list of eigenpair indices ! - WRITE (24, *) - IF (NVEC == 1) THEN - CALL CONVRT2 (IVEC(1), RECORD, LENTH, 'strsum.ivec(1)') - WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be computed.' - ELSE - CALL CONVRT2 (NVEC, RECORD, LENTH, 'strsum.nvec') - WRITE (24, *) RECORD(1:LENTH)//' levels will be computed;' - RECORD(1:20) = ' their indices are: ' - IEND = 20 - DO I = 1, NVEC - IBEG = IEND + 1 - CALL CONVRT2 (IVEC(I), CLEVEL, LENTH, 'strsum.ivec(i)') - IF (I /= NVEC) THEN - IEND = IBEG + LENTH + 1 - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' - ELSE - IEND = IBEG + LENTH - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' - ENDIF - IF (IEND < 120) CYCLE - WRITE (24, *) RECORD(1:IEND) - RECORD(1:2) = ' ' - IEND = 2 - END DO - IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) - ENDIF -! - RETURN -! - 300 FORMAT('The atomic number is ',1F14.10,';') - 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') - 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') + WRITE (24, *) + IF (NVEC == 1) THEN + CALL CONVRT2 (IVEC(1), RECORD, LENTH, 'strsum.ivec(1)') + WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be computed.' + ELSE + CALL CONVRT2 (NVEC, RECORD, LENTH, 'strsum.nvec') + WRITE (24, *) RECORD(1:LENTH)//' levels will be computed;' + RECORD(1:20) = ' their indices are: ' + IEND = 20 + DO I = 1, NVEC + IBEG = IEND + 1 + CALL CONVRT2 (IVEC(I), CLEVEL, LENTH, 'strsum.ivec(i)') + IF (I /= NVEC) THEN + IEND = IBEG + LENTH + 1 + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' + ELSE + IEND = IBEG + LENTH + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' + ENDIF + IF (IEND < 120) CYCLE + WRITE (24, *) RECORD(1:IEND) + RECORD(1:2) = ' ' + IEND = 2 + END DO + IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) + ENDIF +! + RETURN +! + 300 FORMAT('The atomic number is ',1F14.10,';') + 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') + 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') 304 FORMAT(' H (Transverse) --- factor multiplying the',& - ' photon frequency: ',1P,D15.8,';') + ' photon frequency: ',1P,D15.8,';') 305 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 306 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 307 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') 308 FORMAT('Subshell',6X,'e',13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',4X,'MTP'& - ) - 309 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,2(D11.3),I5) - RETURN + ) + 309 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,2(D11.3),I5) + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rci90/strsum_I.f90 b/src/appl/rci90/strsum_I.f90 index a05210712..634f32b9f 100644 --- a/src/appl/rci90/strsum_I.f90 +++ b/src/appl/rci90/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/t.f90 b/src/appl/rci90/t.f90 index d4fbf4406..44ec4ef9f 100644 --- a/src/appl/rci90/t.f90 +++ b/src/appl/rci90/t.f90 @@ -1,19 +1,19 @@ !*********************************************************************** -! +! function relci_qed_F_Klarsfeld(n,kappa,Z) result(F) !-------------------------------------------------------------------- ! Estimates the function F (Z*\alpha) by using a series expansion ! from S Klarsfeld and A Maquet, Physics Letters 43B (1973) 201, -! Eqs (1) and (2) and the table of Bethe logarithms. The -! vacuum-polarization contribution in Eq (2) is omitted. +! Eqs (1) and (2) and the table of Bethe logarithms. The +! vacuum-polarization contribution in Eq (2) is omitted. ! This procedure is adapted from RCI92 of GRASP92, written ! by Farid A Parpia, to the Fortran 95 standard. !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE @@ -31,7 +31,7 @@ function relci_qed_F_Klarsfeld(n,kappa,Z) result(F) -0.0004079_dp, 2.7324291_dp, -0.0461552_dp, -0.0085192_dp, & -0.0027091_dp, -0.0010945_dp, -0.0004997_dp, -0.0002409_dp, & 2.7302673_dp, -0.0467413_dp, -0.0087850_dp, -0.0028591_dp, & - -0.0011904_dp, -0.0005665_dp, -0.0002904_dp, -0.0001539_dp /) + -0.0011904_dp, -0.0005665_dp, -0.0002904_dp, -0.0001539_dp /) ! real(double), parameter :: C401 = 11.0_dp/24.0_dp, & C402 = 3.0_dp/8.0_dp, ovlfac = 4.0_dp/3.0_dp diff --git a/src/appl/rci90/talk.f90 b/src/appl/rci90/talk.f90 index 3a1c24ec8..1cae89a22 100644 --- a/src/appl/rci90/talk.f90 +++ b/src/appl/rci90/talk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! * ! Print coefficients and integral parameters if IBUG1 > 0 and * ! write to disk. * @@ -8,61 +8,61 @@ SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB - USE BUFFER_C + USE BUFFER_C USE debug_C USE orb_C USE cons_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcbuf_I + USE alcbuf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF + INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! Print coefficient if requested ! IF (IBUG1 /= 0) WRITE (99, 300)JA,JB,NP(IA),NH(IA),NP(IB),NH(IB),& - NP(IC),NH(IC),NP(ID),NH(ID),NU,ITYPE,COEF + NP(IC),NH(IC),NP(ID),NH(ID),NU,ITYPE,COEF ! ! Increment counter ! IF(DABS(COEF) > EPS) THEN - NVCOEF = NVCOEF + 1 + NVCOEF = NVCOEF + 1 ! ! Ensure that arrays are of adequate size; reallocate if necessary ! - IF (NVCOEF > NBDIM) CALL ALCBUF (2) + IF (NVCOEF > NBDIM) CALL ALCBUF (2) ! ! Store integral indices and coefficient in COMMON/BUFFER/ ! - LABEL(1,NVCOEF) = IA - LABEL(2,NVCOEF) = IB - LABEL(3,NVCOEF) = IC - LABEL(4,NVCOEF) = ID - LABEL(5,NVCOEF) = NU - LABEL(6,NVCOEF) = ITYPE - COEFF(NVCOEF) = COEF + LABEL(1,NVCOEF) = IA + LABEL(2,NVCOEF) = IB + LABEL(3,NVCOEF) = IC + LABEL(4,NVCOEF) = ID + LABEL(5,NVCOEF) = NU + LABEL(6,NVCOEF) = ITYPE + COEFF(NVCOEF) = COEF END IF ! - RETURN + RETURN ! - 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) - RETURN + 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) + RETURN ! - END SUBROUTINE TALK + END SUBROUTINE TALK diff --git a/src/appl/rci90/talk_I.f90 b/src/appl/rci90/talk_I.f90 index e8373cb48..fd323fa75 100644 --- a/src/appl/rci90/talk_I.f90 +++ b/src/appl/rci90/talk_I.f90 @@ -1,19 +1,19 @@ - MODULE talk_I + MODULE talk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/triangbreit1.f90 b/src/appl/rci90/triangbreit1.f90 index bbfa29715..e62c147ca 100644 --- a/src/appl/rci90/triangbreit1.f90 +++ b/src/appl/rci90/triangbreit1.f90 @@ -9,12 +9,12 @@ LOGICAL FUNCTION TRIANGBREIT1 (IA,IB,IC,ID,K) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s !----------------------------------------------- - USE orb_C, ONLY: NKL, NKJ + USE orb_C, ONLY: NKL, NKJ IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s diff --git a/src/appl/rci90/triangbreit1_I.f90 b/src/appl/rci90/triangbreit1_I.f90 index 69f7ad97d..691b7cb61 100644 --- a/src/appl/rci90/triangbreit1_I.f90 +++ b/src/appl/rci90/triangbreit1_I.f90 @@ -1,9 +1,9 @@ - MODULE TRIANGBREIT1_I + MODULE TRIANGBREIT1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 LOGICAL FUNCTION TRIANGBREIT1 (IA,IB,IC,ID,K) INTEGER, INTENT(IN) :: IA,IB,IC,ID,K - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/triangbreit2.f90 b/src/appl/rci90/triangbreit2.f90 index a1223136c..846383a2f 100644 --- a/src/appl/rci90/triangbreit2.f90 +++ b/src/appl/rci90/triangbreit2.f90 @@ -8,7 +8,7 @@ LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -47,4 +47,3 @@ LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) RETURN END FUNCTION TRIANGBREIT2 - diff --git a/src/appl/rci90/triangbreit2_I.f90 b/src/appl/rci90/triangbreit2_I.f90 index db25eba9f..ce4be2a13 100644 --- a/src/appl/rci90/triangbreit2_I.f90 +++ b/src/appl/rci90/triangbreit2_I.f90 @@ -1,9 +1,9 @@ - MODULE TRIANGBREIT2_I + MODULE TRIANGBREIT2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) INTEGER, INTENT(IN) :: IA,IB,IC,ID,L - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/triangrk.f90 b/src/appl/rci90/triangrk.f90 index 683fff42b..f66e6ff49 100644 --- a/src/appl/rci90/triangrk.f90 +++ b/src/appl/rci90/triangrk.f90 @@ -1,40 +1,40 @@ !*********************************************************************** ! * - LOGICAL FUNCTION TRIANGRK (LA, K, LB) + LOGICAL FUNCTION TRIANGRK (LA, K, LB) ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: LA - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: LB + INTEGER, INTENT(IN) :: LA + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: LB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! Perform the triangularity check ! - IF (MOD(K + LA + LB,2) /= 0) THEN - TRIANGRK = .FALSE. - ELSE - IF (ABS(LA - LB) > K) THEN - TRIANGRK = .FALSE. - ELSE IF (LA + LB < K) THEN - TRIANGRK = .FALSE. - ELSE - TRIANGRK = .TRUE. - ENDIF - ENDIF - - RETURN - END FUNCTION TRIANGRK + IF (MOD(K + LA + LB,2) /= 0) THEN + TRIANGRK = .FALSE. + ELSE + IF (ABS(LA - LB) > K) THEN + TRIANGRK = .FALSE. + ELSE IF (LA + LB < K) THEN + TRIANGRK = .FALSE. + ELSE + TRIANGRK = .TRUE. + ENDIF + ENDIF + + RETURN + END FUNCTION TRIANGRK diff --git a/src/appl/rci90/triangrk_I.f90 b/src/appl/rci90/triangrk_I.f90 index bb81955e6..105bd4f09 100644 --- a/src/appl/rci90/triangrk_I.f90 +++ b/src/appl/rci90/triangrk_I.f90 @@ -1,12 +1,12 @@ - MODULE triangrk_I + MODULE triangrk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL FUNCTION triangrk (LA, K, LB) - INTEGER, INTENT(IN) :: LA - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: LB - END FUNCTION - END INTERFACE - END MODULE + LOGICAL FUNCTION triangrk (LA, K, LB) + INTEGER, INTENT(IN) :: LA + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: LB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vac2.f90 b/src/appl/rci90/vac2.f90 index 5016f9c6b..4f0ae0073 100644 --- a/src/appl/rci90/vac2.f90 +++ b/src/appl/rci90/vac2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VAC2 + SUBROUTINE VAC2 ! * ! This routine sets up the second-order vacuum polarization poten- * ! tial using equations (1) and (4) of L Wayne Fullerton and G A * @@ -14,13 +14,13 @@ SUBROUTINE VAC2 ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE npar_C @@ -29,82 +29,82 @@ SUBROUTINE VAC2 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE funk_I - USE quad_I + USE funk_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K - REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TBI, RK, XK, XI, XM, XP + INTEGER :: I, K + REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TBI, RK, XK, XI, XM, XP !----------------------------------------------- ! ! Overall initialization ! - EPSI = PRECIS*PRECIS - TWOCV = CVAC + CVAC + EPSI = PRECIS*PRECIS + TWOCV = CVAC + CVAC ! ! Potential for a point nucleus: equation (1) ! (this is also the asymptotoc form for a finite nucleus) ! - FACTOR = -(2.0D00*Z)/(3.0D00*PI*CVAC) + FACTOR = -(2.0D00*Z)/(3.0D00*PI*CVAC) ! - TB(1) = 0.0D00 + TB(1) = 0.0D00 ! - I = 1 - 1 CONTINUE - I = I + 1 + I = 1 + 1 CONTINUE + I = I + 1 ! - RI = R(I) - X = TWOCV*RI - TBI = (FACTOR/RI)*FUNK(X,1) + RI = R(I) + X = TWOCV*RI + TBI = (FACTOR/RI)*FUNK(X,1) ! - IF (ABS(TBI) >= EPSI) THEN - TB(I) = TBI - IF (I < N) GO TO 1 - ELSE - TB(I:N) = 0.0D00 - ENDIF + IF (ABS(TBI) >= EPSI) THEN + TB(I) = TBI + IF (I < N) GO TO 1 + ELSE + TB(I:N) = 0.0D00 + ENDIF ! ! Potential for a finite nucleus: equation (4) ! - IF (NPARM == 2) THEN + IF (NPARM == 2) THEN ! - FACTOR = -2.0D00/(3.0D00*CVAC**2) + FACTOR = -2.0D00/(3.0D00*CVAC**2) ! ! Set up integrand ! - TB(1) = 0.0D00 + TB(1) = 0.0D00 ! - K = 1 - 3 CONTINUE - K = K + 1 + K = 1 + 3 CONTINUE + K = K + 1 ! - RK = R(K) - XK = TWOCV*RK + RK = R(K) + XK = TWOCV*RK ! - TA(1) = 0.0D00 - DO I = 2, MTP - XI = TWOCV*R(I) - XM = ABS(XK - XI) - XP = XK + XI - TA(I) = (FUNK(XM,0) - FUNK(XP,0))*ZDIST(I) - END DO + TA(1) = 0.0D00 + DO I = 2, MTP + XI = TWOCV*R(I) + XM = ABS(XK - XI) + XP = XK + XI + TA(I) = (FUNK(XM,0) - FUNK(XP,0))*ZDIST(I) + END DO ! - CALL QUAD (X) + CALL QUAD (X) ! - X = X*FACTOR/RK + X = X*FACTOR/RK ! ! Get out of loop if the asymptotic value has been attained ! - IF (ABS(X) >= EPSI) THEN - IF (ABS((X - TB(K))/X) > 1.0D-05) THEN - TB(K) = X - IF (K < N) GO TO 3 - ENDIF - ENDIF + IF (ABS(X) >= EPSI) THEN + IF (ABS((X - TB(K))/X) > 1.0D-05) THEN + TB(K) = X + IF (K < N) GO TO 3 + ENDIF + ENDIF ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE VAC2 + RETURN + END SUBROUTINE VAC2 diff --git a/src/appl/rci90/vac2_I.f90 b/src/appl/rci90/vac2_I.f90 index 442a068df..590dfd050 100644 --- a/src/appl/rci90/vac2_I.f90 +++ b/src/appl/rci90/vac2_I.f90 @@ -1,9 +1,9 @@ - MODULE vac2_I + MODULE vac2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vac2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vac2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vac4.f90 b/src/appl/rci90/vac4.f90 index 6ee93b299..1d356dee4 100644 --- a/src/appl/rci90/vac4.f90 +++ b/src/appl/rci90/vac4.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VAC4 + SUBROUTINE VAC4 ! * ! This routine sets up the fourth-order vacuum polarization poten- * ! tial using equations (11) and (12) of L Wayne Fullerton and G A * @@ -14,13 +14,13 @@ SUBROUTINE VAC4 ! Written by Farid A Parpia, at Oxford Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE debug_C USE def_C @@ -31,108 +31,108 @@ SUBROUTINE VAC4 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE funl_I - USE quad_I + USE funl_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K, NB2, NROWS, II, II1, II2 - REAL(DOUBLE), DIMENSION(NNNP) :: TC + INTEGER :: I, K, NB2, NROWS, II, II1, II2 + REAL(DOUBLE), DIMENSION(NNNP) :: TC REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TCI, RK, XK, XI, XM, XP !----------------------------------------------- ! ! Overall initialization ! - EPSI = PRECIS*PRECIS - TWOCV = CVAC + CVAC + EPSI = PRECIS*PRECIS + TWOCV = CVAC + CVAC ! ! Potential for point nucleus: equation (12) ! - FACTOR = -Z/(PI*CVAC)**2 + FACTOR = -Z/(PI*CVAC)**2 ! - TC(1) = 0.0D00 + TC(1) = 0.0D00 ! - I = 1 - 1 CONTINUE - I = I + 1 - RI = R(I) - X = TWOCV*RI - TCI = (FACTOR/RI)*FUNL(X,1) - IF (ABS(TCI) >= EPSI) THEN - TC(I) = TCI - IF (I < N) GO TO 1 - ELSE - TC(I:N) = 0.0D00 - ENDIF + I = 1 + 1 CONTINUE + I = I + 1 + RI = R(I) + X = TWOCV*RI + TCI = (FACTOR/RI)*FUNL(X,1) + IF (ABS(TCI) >= EPSI) THEN + TC(I) = TCI + IF (I < N) GO TO 1 + ELSE + TC(I:N) = 0.0D00 + ENDIF ! ! Potential for finite nucleus: equation (11) ! - IF (NPARM == 2) THEN + IF (NPARM == 2) THEN ! - FACTOR = -1.0D00/(PI*CVAC**3) + FACTOR = -1.0D00/(PI*CVAC**3) ! - TC(1) = 0.0D00 + TC(1) = 0.0D00 ! - K = 1 - 3 CONTINUE - K = K + 1 + K = 1 + 3 CONTINUE + K = K + 1 ! - RK = R(K) - XK = TWOCV*RK - TA(1) = 0.0D00 + RK = R(K) + XK = TWOCV*RK + TA(1) = 0.0D00 ! - DO I = 2, MTP - XI = TWOCV*R(I) - XM = ABS(XK - XI) - XP = XK + XI - TA(I) = (FUNL(XM,0) - FUNL(XP,0))*ZDIST(I) - END DO + DO I = 2, MTP + XI = TWOCV*R(I) + XM = ABS(XK - XI) + XP = XK + XI + TA(I) = (FUNL(XM,0) - FUNL(XP,0))*ZDIST(I) + END DO ! - CALL QUAD (X) + CALL QUAD (X) ! - X = X*FACTOR/RK + X = X*FACTOR/RK ! ! Get out of the loop if the asymptotic region has been reached ! - IF (ABS(X) >= EPSI) THEN - IF (ABS((TC(K)-X)/X) > 1.0D-03) THEN - TC(K) = X - IF (K < N) GO TO 3 - ENDIF - ENDIF -! - ENDIF -! - IF (LDBPR(8)) THEN - WRITE (99, 300) - NB2 = N/2 - IF (2*NB2 == N) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= N) THEN + IF (ABS(X) >= EPSI) THEN + IF (ABS((TC(K)-X)/X) > 1.0D-03) THEN + TC(K) = X + IF (K < N) GO TO 3 + ENDIF + ENDIF +! + ENDIF +! + IF (LDBPR(8)) THEN + WRITE (99, 300) + NB2 = N/2 + IF (2*NB2 == N) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= N) THEN WRITE (99, 301) R(II1), TB(II1), TC(II1), R(II2), TB(II2), TC(& - II2) - ELSE IF (II1 <= N) THEN - WRITE (99, 301) R(II1), TB(II1), TC(II1) - ENDIF - END DO - ENDIF + II2) + ELSE IF (II1 <= N) THEN + WRITE (99, 301) R(II1), TB(II1), TC(II1) + ENDIF + END DO + ENDIF ! ! Generate total vacuum-polarization potential ! - TB(:N) = TC(:N) + TB(:N) + TB(:N) = TC(:N) + TB(:N) ! - RETURN + RETURN ! 300 FORMAT(/,/,/,' ++++++++++ VAC4 ++++++++++'/,/,2(& - ' -------- r -------- ----- VV2 (r) -----',' ----- VV4 (r) -----')) - 301 FORMAT(1P,6(1X,1D19.12)) - RETURN + ' -------- r -------- ----- VV2 (r) -----',' ----- VV4 (r) -----')) + 301 FORMAT(1P,6(1X,1D19.12)) + RETURN ! - END SUBROUTINE VAC4 + END SUBROUTINE VAC4 diff --git a/src/appl/rci90/vac4_I.f90 b/src/appl/rci90/vac4_I.f90 index 92ea384de..98e74e2c7 100644 --- a/src/appl/rci90/vac4_I.f90 +++ b/src/appl/rci90/vac4_I.f90 @@ -1,9 +1,9 @@ - MODULE vac4_I + MODULE vac4_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vac4 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vac4 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vacpol.f90 b/src/appl/rci90/vacpol.f90 index 82747f01b..73a4a86fc 100644 --- a/src/appl/rci90/vacpol.f90 +++ b/src/appl/rci90/vacpol.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VACPOL + SUBROUTINE VACPOL ! * ! This routine controls the setting up of the vacuum polarization * ! potential for the given nuclear charge distribution at each grid * @@ -14,13 +14,13 @@ SUBROUTINE VACPOL ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE npar_C USE ncdist_C @@ -28,31 +28,31 @@ SUBROUTINE VACPOL !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE vac2_I - USE vac4_I + USE vac2_I + USE vac4_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! ! Redefine ZDIST to be rho*r*r' ! - ZDIST(:MTP) = ZDIST(:MTP)*R(:MTP)*RP(:MTP) + ZDIST(:MTP) = ZDIST(:MTP)*R(:MTP)*RP(:MTP) ! ! Second-order vacuum polarisation potential; returned in ! array TB ! - CALL VAC2 + CALL VAC2 ! ! Fourth-order vacuum polarization potential; returned in ! array TA ! - CALL VAC4 + CALL VAC4 ! ! If option 7 is set, use user-defined vacuum polarization ! potential ! - RETURN - END SUBROUTINE VACPOL + RETURN + END SUBROUTINE VACPOL diff --git a/src/appl/rci90/vacpol_I.f90 b/src/appl/rci90/vacpol_I.f90 index 6683ba54c..6c25cb73c 100644 --- a/src/appl/rci90/vacpol_I.f90 +++ b/src/appl/rci90/vacpol_I.f90 @@ -1,9 +1,9 @@ - MODULE vacpol_I + MODULE vacpol_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vacpol - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vacpol + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vint_I.f90 b/src/appl/rci90/vint_I.f90 index 8df3d28e2..291bd0fb0 100644 --- a/src/appl/rci90/vint_I.f90 +++ b/src/appl/rci90/vint_I.f90 @@ -1,12 +1,12 @@ - MODULE vint_I + MODULE vint_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE VINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER, INTENT(IN) :: IA, IB REAl(DOUBLE), INTENT(OUT) :: TEGRAL END SUBROUTINE vint - END INTERFACE - END MODULE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vinti.f90 b/src/appl/rci90/vinti.f90 index 3bcedf4f9..f6875132b 100644 --- a/src/appl/rci90/vinti.f90 +++ b/src/appl/rci90/vinti.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) + REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! * ! The value of this function is the one-electron integral V (J,K) * ! for orbitals J, K. The analytical expression for this quantity * @@ -12,13 +12,13 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! Written by M Tong and F A Parpia, Last revision: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE grid_C USE orb_C @@ -27,56 +27,56 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dpbdt_I - USE quad_I + USE dpbdt_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: K + INTEGER :: J + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 - REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 + INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 + REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 !----------------------------------------------- ! - MTP = MAX(MF(J),MF(K)) + MTP = MAX(MF(J),MF(K)) ! ! Piece involving derivatives ! - CALL DPBDT (K) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = PIECE1/H + CALL DPBDT (K) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = PIECE1/H ! ! Pieces not involving derivatives ! - KPJ = NAK(J) - KPK = NAK(K) - IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) - FACT1 = 0.5D00*DBLE(IFACT1) - IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) - FACT2 = 0.5D00*DBLE(IFACT2) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K)) - END DO - CALL QUAD (PIECE2) + KPJ = NAK(J) + KPK = NAK(K) + IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) + FACT1 = 0.5D00*DBLE(IFACT1) + IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) + FACT2 = 0.5D00*DBLE(IFACT2) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K)) + END DO + CALL QUAD (PIECE2) ! - VINTI = PIECE1 - PIECE2 + VINTI = PIECE1 - PIECE2 ! ! Debug printout ! - IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI + IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI ! - RETURN + RETURN ! - 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) - RETURN + 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) + RETURN ! - END FUNCTION VINTI + END FUNCTION VINTI diff --git a/src/appl/rci90/vinti_I.f90 b/src/appl/rci90/vinti_I.f90 index 3ae6f3a41..d9af3126a 100644 --- a/src/appl/rci90/vinti_I.f90 +++ b/src/appl/rci90/vinti_I.f90 @@ -1,11 +1,11 @@ - MODULE vinti_I + MODULE vinti_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION vinti (J, K) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION vinti (J, K) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vpint.f90 b/src/appl/rci90/vpint.f90 index a88f078b0..5988326fd 100644 --- a/src/appl/rci90/vpint.f90 +++ b/src/appl/rci90/vpint.f90 @@ -10,7 +10,7 @@ SUBROUTINE VPINT (IA,IB,TEGRAL) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/vpint_I.f90 b/src/appl/rci90/vpint_I.f90 index 759341c6e..d0734ee27 100644 --- a/src/appl/rci90/vpint_I.f90 +++ b/src/appl/rci90/vpint_I.f90 @@ -1,11 +1,11 @@ - MODULE vpint_I + MODULE vpint_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE VPINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER , INTENT(IN) :: IA, IB REAl(DOUBLE), INTENT(OUT) :: TEGRAL - END SUBROUTINE vpint - END INTERFACE - END MODULE + END SUBROUTINE vpint + END INTERFACE + END MODULE diff --git a/src/appl/rci90/vpintf.f90 b/src/appl/rci90/vpintf.f90 index e52a48ca0..0de94573d 100644 --- a/src/appl/rci90/vpintf.f90 +++ b/src/appl/rci90/vpintf.f90 @@ -8,7 +8,7 @@ REAL(KIND(0.0D0)) FUNCTION VPINTF (IA,IB) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90/vpintf_I.f90 b/src/appl/rci90/vpintf_I.f90 index a663f87ad..4593275fd 100644 --- a/src/appl/rci90/vpintf_I.f90 +++ b/src/appl/rci90/vpintf_I.f90 @@ -1,9 +1,9 @@ - MODULE vpintf_I + MODULE vpintf_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION VPINTF (IA,IB) INTEGER , INTENT(IN) :: IA, IB - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90/wghtd5.f90 b/src/appl/rci90/wghtd5.f90 index a66ac2f90..f6936be95 100644 --- a/src/appl/rci90/wghtd5.f90 +++ b/src/appl/rci90/wghtd5.f90 @@ -10,7 +10,7 @@ SUBROUTINE WGHTD5(iatjpo, iaspar) ! Last updated: 02 Nov 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -34,7 +34,7 @@ SUBROUTINE WGHTD5(iatjpo, iaspar) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - + INTEGER, DIMENSION(5) :: ICONF ! REAL(DOUBLE), DIMENSION(5) :: WGHT(5) REAL(DOUBLE), DIMENSION(5) :: WT(5) diff --git a/src/appl/rci90/wghtd5_I.f90 b/src/appl/rci90/wghtd5_I.f90 index 56f643140..6d837033a 100644 --- a/src/appl/rci90/wghtd5_I.f90 +++ b/src/appl/rci90/wghtd5_I.f90 @@ -1,9 +1,9 @@ MODULE wghtd5_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE WGHTD5(iatjpo, iaspar) INTEGER, INTENT(IN) :: iatjpo, iaspar - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90/zkf.f90 b/src/appl/rci90/zkf.f90 index 90c0cd5cc..d630b5083 100644 --- a/src/appl/rci90/zkf.f90 +++ b/src/appl/rci90/zkf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ZKF(K, I, J) + SUBROUTINE ZKF(K, I, J) ! * ! This subroutine evaluates Hartree Z-functionals: * ! * @@ -14,13 +14,13 @@ SUBROUTINE ZKF(K, I, J) ! Written by Farid A Parpia, at Oxford Last updated: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNN1 USE cnc_C, ONLY: cnc5c USE grid_C, ONLY: n, r, rp @@ -30,81 +30,81 @@ SUBROUTINE ZKF(K, I, J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: K - INTEGER :: I + INTEGER, INTENT(IN) :: K + INTEGER :: I INTEGER :: J !!!! Arument not referenced !!! !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II, MTPP1, MTPP3, MTPP4, KK + INTEGER :: II, MTPP1, MTPP3, MTPP4, KK REAL(DOUBLE), DIMENSION(NNN1) :: RHOP, RTTK, TEMP - REAL(DOUBLE) :: SUM, ZKLIM + REAL(DOUBLE) :: SUM, ZKLIM !----------------------------------------------- ! - IF (K > 0) THEN - RTTK(2:N) = R(2:N)**K - ENDIF + IF (K > 0) THEN + RTTK(2:N) = R(2:N)**K + ENDIF ! ! MTP is fed in through COMMON/TATB/ ! - MTPP1 = MTP + 1 - MTPP3 = MTP + 3 - MTPP4 = MTP + 4 + MTPP1 = MTP + 1 + MTPP3 = MTP + 3 + MTPP4 = MTP + 4 ! ! Compute RP(S)*F(S) and store it in RHOP ! - RHOP(2:MTP) = RP(2:MTP)*TA(2:MTP) + RHOP(2:MTP) = RP(2:MTP)*TA(2:MTP) ! ! Fill array TEMP with r**k * RHOP ! - TEMP(1) = 0.0D00 - IF (K == 0) THEN - TEMP(2:MTP) = RHOP(2:MTP) - ELSE - TEMP(2:MTP) = RTTK(2:MTP)*RHOP(2:MTP) - ENDIF + TEMP(1) = 0.0D00 + IF (K == 0) THEN + TEMP(2:MTP) = RHOP(2:MTP) + ELSE + TEMP(2:MTP) = RTTK(2:MTP)*RHOP(2:MTP) + ENDIF ! ! Set an additional four points to zero ! - TEMP(MTPP1:MTPP4) = 0.0D00 + TEMP(MTPP1:MTPP4) = 0.0D00 ! ! k ! Compute the first few values of r * ZK using semi-open ! Newton-Cotes formulae ! - ZK(1) = 0.0D00 - DO II = 2, 4 - SUM = 0.0D00 - DO KK = 2, 5 - SUM = SUM + CNC5C(KK,II)*TEMP(KK) - END DO - ZK(II) = SUM - END DO + ZK(1) = 0.0D00 + DO II = 2, 4 + SUM = 0.0D00 + DO KK = 2, 5 + SUM = SUM + CNC5C(KK,II)*TEMP(KK) + END DO + ZK(II) = SUM + END DO ! k ! Compute remainder of r * ZK: march out to MTP+3 ! - DO II = 5, MTPP3 + DO II = 5, MTPP3 ZK(II) = ZK(II-4) + C1*(TEMP(II-4)+TEMP(II)) + C2*(TEMP(II-3)+TEMP(II-& - 1)) + C3*TEMP(II-2) - END DO + 1)) + C3*TEMP(II-2) + END DO ! k (k) ! Determine the asymptotic value of r * Z ! ! Compute ZK ! - ZKLIM = ZK(MTPP3) + ZKLIM = ZK(MTPP3) ! - IF (K == 0) THEN + IF (K == 0) THEN ! - ZK(MTPP4:N) = ZKLIM + ZK(MTPP4:N) = ZKLIM ! - ELSE + ELSE ! - ZK(2:MTPP3) = ZK(2:MTPP3)/RTTK(2:MTPP3) + ZK(2:MTPP3) = ZK(2:MTPP3)/RTTK(2:MTPP3) ! - ZK(MTPP4:N) = ZKLIM/RTTK(MTPP4:N) + ZK(MTPP4:N) = ZKLIM/RTTK(MTPP4:N) ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE ZKF + RETURN + END SUBROUTINE ZKF diff --git a/src/appl/rci90/zkf_I.f90 b/src/appl/rci90/zkf_I.f90 index 4ef0a5bd5..88fe25d11 100644 --- a/src/appl/rci90/zkf_I.f90 +++ b/src/appl/rci90/zkf_I.f90 @@ -1,13 +1,13 @@ - MODULE zkf_I + MODULE zkf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE zkf (K, I, J) - INTEGER, INTENT(IN) :: K - INTEGER :: I + SUBROUTINE zkf (K, I, J) + INTEGER, INTENT(IN) :: K + INTEGER :: I !VAST...Dummy argument I is not referenced in this routine. - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/Makefile b/src/appl/rci90_mpi/Makefile old mode 100755 new mode 100644 index c413e9925..c94857c6e --- a/src/appl/rci90_mpi/Makefile +++ b/src/appl/rci90_mpi/Makefile @@ -15,7 +15,7 @@ MODLMPIU90 = ${SRCLIBDIR}/mpi90 GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 -lmpiu90 -l9290 -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} # Define data types VASTO = ${MODDIR}/vast_kind_param_M.o @@ -53,7 +53,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) $(LAPACK_LIBS) + $(APP_LIBS) $(LAPACK_LIBS) .f90.o: $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ @@ -64,4 +64,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rci90_mpi/auxblk.f90 b/src/appl/rci90_mpi/auxblk.f90 index 3c7fbdd40..b1d25822f 100644 --- a/src/appl/rci90_mpi/auxblk.f90 +++ b/src/appl/rci90_mpi/auxblk.f90 @@ -1,13 +1,13 @@ -!************************************************************************ - SUBROUTINE AUXBLK(J2MAX, ATWINV) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ + SUBROUTINE AUXBLK(J2MAX, ATWINV) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE decide_C USE def_C @@ -24,87 +24,87 @@ SUBROUTINE AUXBLK(J2MAX, ATWINV) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ncharg_I - USE vacpol_I + USE ncharg_I + USE vacpol_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J2MAX - REAL(DOUBLE), INTENT(OUT) :: ATWINV + INTEGER, INTENT(IN) :: J2MAX + REAL(DOUBLE), INTENT(OUT) :: ATWINV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K - LOGICAL :: LDBPG + INTEGER :: I, K + LOGICAL :: LDBPG !----------------------------------------------- ! - FRSTCO = .TRUE. - NCOEI = 0 - - IF (LTRANS) THEN + FRSTCO = .TRUE. + NCOEI = 0 + + IF (LTRANS) THEN ! ...Check the maximum numbers of orbtitals allowed in brint.f - I = NNNW - SELECT CASE (J2MAX) - CASE (11) - I = 114 - CASE (12) - I = 112 - CASE (13) - I = 110 - CASE (14) - I = 108 - CASE (15) - I = 106 - CASE (16) - I = 105 - CASE (17) - I = 103 - CASE (18) - I = 101 - CASE (19) - I = 100 - CASE (21:) - I = 90 - END SELECT - - IF (I < NW) THEN - WRITE (ISTDE, *) 'In setham. The number of orbitals is too' - WRITE (ISTDE, *) 'large for the brint routine' - STOP - ENDIF - - FIRST = .TRUE. - NTPI = 0 - ENDIF + I = NNNW + SELECT CASE (J2MAX) + CASE (11) + I = 114 + CASE (12) + I = 112 + CASE (13) + I = 110 + CASE (14) + I = 108 + CASE (15) + I = 106 + CASE (16) + I = 105 + CASE (17) + I = 103 + CASE (18) + I = 101 + CASE (19) + I = 100 + CASE (21:) + I = 90 + END SELECT + + IF (I < NW) THEN + WRITE (ISTDE, *) 'In setham. The number of orbitals is too' + WRITE (ISTDE, *) 'large for the brint routine' + STOP + ENDIF + + FIRST = .TRUE. + NTPI = 0 + ENDIF ! ! Initialisations for the vacuum polarisation corrections ! - IF (LVP) THEN - CALL NCHARG - CALL VACPOL - ZDIST(2:N) = TB(2:N)*RP(2:N) - FRSTVP = .TRUE. - NVPI = 0 - ENDIF + IF (LVP) THEN + CALL NCHARG + CALL VACPOL + ZDIST(2:N) = TB(2:N)*RP(2:N) + FRSTVP = .TRUE. + NVPI = 0 + ENDIF ! ! Initialisations for nuclear translational energy corrections ! - IF (EMN > 0.D0) THEN - ATWINV = 1.D0/EMN - IF (LNMS) THEN - FRSTKI = .TRUE. - NKEI = 0 - ENDIF - IF (LSMS) THEN - FRSTVI = .TRUE. - NVINTI = 0 - ENDIF - ELSE + IF (EMN > 0.D0) THEN + ATWINV = 1.D0/EMN + IF (LNMS) THEN + FRSTKI = .TRUE. + NKEI = 0 + ENDIF + IF (LSMS) THEN + FRSTVI = .TRUE. + NVINTI = 0 + ENDIF + ELSE ! atwinv will not be used - LNMS = .FALSE. - LSMS = .FALSE. - ENDIF - - RETURN - END SUBROUTINE AUXBLK + LNMS = .FALSE. + LSMS = .FALSE. + ENDIF + + RETURN + END SUBROUTINE AUXBLK diff --git a/src/appl/rci90_mpi/auxblk_I.f90 b/src/appl/rci90_mpi/auxblk_I.f90 index c4b6cea41..a94227794 100644 --- a/src/appl/rci90_mpi/auxblk_I.f90 +++ b/src/appl/rci90_mpi/auxblk_I.f90 @@ -1,12 +1,12 @@ - MODULE auxblk_I + MODULE auxblk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE auxblk (J2MAX, ATWINV) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J2MAX - REAL(DOUBLE), INTENT(OUT) :: ATWINV - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE auxblk (J2MAX, ATWINV) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J2MAX + REAL(DOUBLE), INTENT(OUT) :: ATWINV + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/bessel.f90 b/src/appl/rci90_mpi/bessel.f90 index 061c81263..4b0ae839a 100644 --- a/src/appl/rci90_mpi/bessel.f90 +++ b/src/appl/rci90_mpi/bessel.f90 @@ -1,8 +1,8 @@ !*********************************************************************** ! * - SUBROUTINE BESSEL(IA, IB, IK, IW, K) + SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- ! * ! This routine evaluates the functions * @@ -37,13 +37,13 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M O D U L E S !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE bess_C USE debug_C @@ -56,11 +56,11 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: IW - INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: IW + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- @@ -68,174 +68,174 @@ SUBROUTINE BESSEL(IA, IB, IK, IW, K) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ICODE, IWKP, IKKP, L, I, NN, J, JCHAN, IREM, ISWAP + INTEGER :: ICODE, IWKP, IKKP, L, I, NN, J, JCHAN, IREM, ISWAP REAL(DOUBLE) :: EPSI, W, WA, XBESS1, XBESS2, S1, S2, DFNM, DFN, SSN, SCN& - , SN, CN, OBWA, B, SKEEP + , SN, CN, OBWA, B, SKEEP !----------------------------------------------- ! - EPSI = DSQRT(0.1D00*ACCY) + EPSI = DSQRT(0.1D00*ACCY) ! ! Form unique label symmetric in IA, IB ! - ICODE = MAX(IA,IB) + KEY*(MIN(IA,IB) + KEY*K) + ICODE = MAX(IA,IB) + KEY*(MIN(IA,IB) + KEY*K) ! ! Function in position; return ! - IF (ICODE == KEEP(IK,IW)) RETURN + IF (ICODE == KEEP(IK,IW)) RETURN ! ! Function not in position; is it available in BESS arrays? ! - W = WFACT*DABS(E(IA)-E(IB))/C - WIJ(IW) = W + W = WFACT*DABS(E(IA)-E(IB))/C + WIJ(IW) = W ! - DO IWKP = 1, 2 - DO IKKP = 1, 2 - IF (KEEP(IKKP,IWKP) /= ICODE) CYCLE + DO IWKP = 1, 2 + DO IKKP = 1, 2 + IF (KEEP(IKKP,IWKP) /= ICODE) CYCLE ! ! Function found move into position ! - KEEP(IK,IW) = ICODE + KEEP(IK,IW) = ICODE IF (LDBPR(7)) WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB), K, & - IKKP, IWKP, IK, IW - BESSJ(IK,IW,:N) = BESSJ(IKKP,IWKP,:N) - BESSN(IK,IW,:N) = BESSN(IKKP,IWKP,:N) - RETURN - END DO - END DO + IKKP, IWKP, IK, IW + BESSJ(IK,IW,:N) = BESSJ(IKKP,IWKP,:N) + BESSN(IK,IW,:N) = BESSN(IKKP,IWKP,:N) + RETURN + END DO + END DO ! ! Function not found; evaluate it ! - IF (LDBPR(7)) WRITE (99, 303) NP(IA), NH(IA), NP(IB), NH(IB), K, IK, IW + IF (LDBPR(7)) WRITE (99, 303) NP(IA), NH(IA), NP(IB), NH(IB), K, IK, IW ! - KEEP(IK,IW) = ICODE + KEEP(IK,IW) = ICODE ! - IF (W < EPSI**2) THEN + IF (W < EPSI**2) THEN ! ! Negligible w ! - BESSJ(IK,IW,:N) = 0.0D00 - BESSN(IK,IW,:N) = 0.0D00 - RETURN + BESSJ(IK,IW,:N) = 0.0D00 + BESSN(IK,IW,:N) = 0.0D00 + RETURN ! - ENDIF + ENDIF ! - NN = K + NN = K ! - BESSJ(IK,IW,1) = 0.0D00 - BESSN(IK,IW,1) = 0.0D00 + BESSJ(IK,IW,1) = 0.0D00 + BESSN(IK,IW,1) = 0.0D00 ! ! Use a four-term power series for low w*r ! - L5: DO J = 2, N - WA = -0.5D00*(R(J)*W)**2 - XBESS1 = 1.0D00 - XBESS2 = 1.0D00 - S1 = 0.0D00 - S2 = 0.0D00 - DO I = 1, 4 - XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) - XBESS2 = XBESS2*WA/DBLE(I*(2*(I - NN) - 1)) - S1 = S1 + XBESS1 - S2 = S2 + XBESS2 + L5: DO J = 2, N + WA = -0.5D00*(R(J)*W)**2 + XBESS1 = 1.0D00 + XBESS2 = 1.0D00 + S1 = 0.0D00 + S2 = 0.0D00 + DO I = 1, 4 + XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) + XBESS2 = XBESS2*WA/DBLE(I*(2*(I - NN) - 1)) + S1 = S1 + XBESS1 + S2 = S2 + XBESS2 IF (DABS(XBESS1)>=DABS(S1)*EPSI .OR. DABS(XBESS2)>=DABS(S2)*EPSI) & - CYCLE - BESSJ(IK,IW,J) = S1 - BESSN(IK,IW,J) = S2 - CYCLE L5 - END DO - JCHAN = J - GO TO 6 - END DO L5 + CYCLE + BESSJ(IK,IW,J) = S1 + BESSN(IK,IW,J) = S2 + CYCLE L5 + END DO + JCHAN = J + GO TO 6 + END DO L5 ! ! If here then calculated whole array using four-term power ! series. Hence return ! - RETURN + RETURN ! ! Use sin/cos expansion when power series requires more than ! four terms terms to converge ! - 6 CONTINUE - IF (NN == 0) THEN - DFNM = 1.0D00 - DFN = 1.0D00 - ELSE - DFNM = 1.0D00 - DO I = 3, 2*NN - 1, 2 - DFNM = DFNM*DBLE(I) - END DO - DFN = DFNM*DBLE(2*NN + 1) - ENDIF - DFNM = 1.0D00/DFNM + 6 CONTINUE + IF (NN == 0) THEN + DFNM = 1.0D00 + DFN = 1.0D00 + ELSE + DFNM = 1.0D00 + DO I = 3, 2*NN - 1, 2 + DFNM = DFNM*DBLE(I) + END DO + DFN = DFNM*DBLE(2*NN + 1) + ENDIF + DFNM = 1.0D00/DFNM ! - IREM = MOD(NN,4) + IREM = MOD(NN,4) ! - SELECT CASE (IREM) - CASE (1) + SELECT CASE (IREM) + CASE (1) ! ! NN = 1, 5, 9, ... ! - SSN = -1.0D00 - SCN = 1.0D00 - ISWAP = 1 + SSN = -1.0D00 + SCN = 1.0D00 + ISWAP = 1 ! - CASE (2) + CASE (2) ! ! N = 2, 6, 10, .... ! - SSN = -1.0D00 - SCN = -1.0D00 - ISWAP = 0 + SSN = -1.0D00 + SCN = -1.0D00 + ISWAP = 0 ! - CASE (3) + CASE (3) ! ! NN = 3, 7, 11,... ! - SSN = 1.0D00 - SCN = -1.0D00 - ISWAP = 1 + SSN = 1.0D00 + SCN = -1.0D00 + ISWAP = 1 ! - CASE DEFAULT + CASE DEFAULT ! ! NN = 0, 4, 8,... ! - SSN = 1.0D00 - SCN = 1.0D00 - ISWAP = 0 -! - END SELECT -! - DO J = JCHAN, N - WA = W*R(J) - IF (ISWAP == 0) THEN - SN = SSN*DSIN(WA) - CN = SCN*DCOS(WA) - ELSE - SN = SSN*DCOS(WA) - CN = SCN*DSIN(WA) - ENDIF - OBWA = 1.0D00/WA - B = OBWA - S1 = B*SN - S2 = B*CN - DO I = 1, NN - SKEEP = SN - SN = CN - CN = -SKEEP - B = B*OBWA*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I) - S1 = S1 + B*SN - S2 = S2 + B*CN - END DO - S1 = S1*DFN/WA**NN - 1.0D00 - S2 = S2*WA**(NN + 1)*DFNM - 1.0D00 - BESSJ(IK,IW,J) = S1 - BESSN(IK,IW,J) = S2 - END DO - RETURN -! - 303 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'New',6X,'(',I2,',',I2,')') + SSN = 1.0D00 + SCN = 1.0D00 + ISWAP = 0 +! + END SELECT +! + DO J = JCHAN, N + WA = W*R(J) + IF (ISWAP == 0) THEN + SN = SSN*DSIN(WA) + CN = SCN*DCOS(WA) + ELSE + SN = SSN*DCOS(WA) + CN = SCN*DSIN(WA) + ENDIF + OBWA = 1.0D00/WA + B = OBWA + S1 = B*SN + S2 = B*CN + DO I = 1, NN + SKEEP = SN + SN = CN + CN = -SKEEP + B = B*OBWA*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I) + S1 = S1 + B*SN + S2 = S2 + B*CN + END DO + S1 = S1*DFN/WA**NN - 1.0D00 + S2 = S2*WA**(NN + 1)*DFNM - 1.0D00 + BESSJ(IK,IW,J) = S1 + BESSN(IK,IW,J) = S2 + END DO + RETURN +! + 303 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'New',6X,'(',I2,',',I2,')') 302 FORMAT(93X,I2,A2,2X,I2,A2,2X,I2,2X,'(',I2,',',I2,')',2X,'(',I2,',',I2,')'& - ) - RETURN + ) + RETURN ! - END SUBROUTINE BESSEL + END SUBROUTINE BESSEL diff --git a/src/appl/rci90_mpi/bessel_I.f90 b/src/appl/rci90_mpi/bessel_I.f90 index 1da0cc215..c31c1c7c4 100644 --- a/src/appl/rci90_mpi/bessel_I.f90 +++ b/src/appl/rci90_mpi/bessel_I.f90 @@ -1,14 +1,14 @@ - MODULE bessel_I + MODULE bessel_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bessel (IA, IB, IK, IW, K) - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IK - INTEGER, INTENT(IN) :: IW - INTEGER, INTENT(IN) :: K - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bessel (IA, IB, IK, IW, K) + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IK + INTEGER, INTENT(IN) :: IW + INTEGER, INTENT(IN) :: K + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/breid.f90 b/src/appl/rci90_mpi/breid.f90 index ed9eac061..884d8c158 100644 --- a/src/appl/rci90_mpi/breid.f90 +++ b/src/appl/rci90_mpi/breid.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) + SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) ! * ! Computes closed shell contributions - aaaa and exchange only. * ! * @@ -9,13 +9,13 @@ SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) ! LAST UPDATE: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bcore_C USE cons_C USE debug_C @@ -24,162 +24,162 @@ SUBROUTINE BREID(JA, JB, JA1, IPCA, JB1) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE snrc_I - USE clrx_I - USE talk_I - USE itrig_I - USE cxk_I + USE snrc_I + USE clrx_I + USE talk_I + USE itrig_I + USE cxk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 + INTEGER :: JA + INTEGER :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NUMAX = 20 + INTEGER, PARAMETER :: NUMAX = 20 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(4) :: JS, KAPS, KS + INTEGER, DIMENSION(4) :: JS, KAPS, KS INTEGER :: IA1, IB1, ISG, NQS1, NQS2, I, ND1, ND2, NE1, NE2, IBRD, IBRE, & - N, NU, K, KAP1, ITYPE, MU, IP, IPP, KK, NUP1 - REAL(DOUBLE), DIMENSION(7,20) :: CONE - REAL(DOUBLE), DIMENSION(12) :: S - REAL(DOUBLE) :: CONST, GAM, DKSKS, DNUNU1, COEF, PROC, PROD + N, NU, K, KAP1, ITYPE, MU, IP, IPP, KK, NUP1 + REAL(DOUBLE), DIMENSION(7,20) :: CONE + REAL(DOUBLE), DIMENSION(12) :: S + REAL(DOUBLE) :: CONST, GAM, DKSKS, DNUNU1, COEF, PROC, PROD !----------------------------------------------- ! ! 1.0 Initialization ! - IF (IPCA == 2) THEN - IA1 = KLIST(JA1) - ELSE - IA1 = JLIST(JA1) - ENDIF - IB1 = KLIST(JB1) -! - ISG = 1 - IF (JA == JB) THEN - IF (ICORE(IA1)/=0 .AND. ICORE(IB1)/=0) THEN - IF (JA > 1) RETURN - ISG = -1 - ENDIF - ENDIF -! - JS(1) = IA1 - JS(2) = IB1 - JS(3) = IA1 - JS(4) = IB1 - NQS1 = NQ1(IA1) - NQS2 = NQ2(IB1) - DO I = 1, 4 - KAPS(I) = 2*NAK(JS(I)) - KS(I) = IABS(KAPS(I)) - END DO - CONST = NQS1*NQS2 - IF (IBUG2 /= 0) WRITE (99, 300) IA1, IB1 + IF (IPCA == 2) THEN + IA1 = KLIST(JA1) + ELSE + IA1 = JLIST(JA1) + ENDIF + IB1 = KLIST(JB1) +! + ISG = 1 + IF (JA == JB) THEN + IF (ICORE(IA1)/=0 .AND. ICORE(IB1)/=0) THEN + IF (JA > 1) RETURN + ISG = -1 + ENDIF + ENDIF +! + JS(1) = IA1 + JS(2) = IB1 + JS(3) = IA1 + JS(4) = IB1 + NQS1 = NQ1(IA1) + NQS2 = NQ2(IB1) + DO I = 1, 4 + KAPS(I) = 2*NAK(JS(I)) + KS(I) = IABS(KAPS(I)) + END DO + CONST = NQS1*NQS2 + IF (IBUG2 /= 0) WRITE (99, 300) IA1, IB1 ! ! 2.0 Set range of tensor indices ! - CALL SNRC (JS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) - IF (IBUG2 /= 0) WRITE (99, 301) ND1, ND2, NE1, NE2, IBRD, IBRE - IF (IA1 == IB1) THEN + CALL SNRC (JS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + IF (IBUG2 /= 0) WRITE (99, 301) ND1, ND2, NE1, NE2, IBRD, IBRE + IF (IA1 == IB1) THEN ! ! 3.0 Calculate aaaa interaction ! - DO N = 1, ND2 - NU = ND1 + 2*(N - 1) - K = NU - IF (MOD(K,2) /= 1) RETURN - KAP1 = KAPS(1)/2 - GAM = CLRX(KAP1,NU,KAP1) - DKSKS = KS(1)*KS(1) - DNUNU1 = NU*(NU + 1) - COEF = CONST*TWO*DKSKS*GAM*GAM/DNUNU1 - IF (IBUG2 /= 0) WRITE (99, 302) NU, GAM, COEF - ITYPE = ISG*4 - CALL TALK (JA, JB, NU, IA1, IA1, IA1, IA1, ITYPE, COEF) - END DO - RETURN - ENDIF + DO N = 1, ND2 + NU = ND1 + 2*(N - 1) + K = NU + IF (MOD(K,2) /= 1) RETURN + KAP1 = KAPS(1)/2 + GAM = CLRX(KAP1,NU,KAP1) + DKSKS = KS(1)*KS(1) + DNUNU1 = NU*(NU + 1) + COEF = CONST*TWO*DKSKS*GAM*GAM/DNUNU1 + IF (IBUG2 /= 0) WRITE (99, 302) NU, GAM, COEF + ITYPE = ISG*4 + CALL TALK (JA, JB, NU, IA1, IA1, IA1, IA1, ITYPE, COEF) + END DO + RETURN + ENDIF ! ! Calculate exchange interactions ! - IF (IBRE < 0) RETURN - IF (NE2 > NUMAX) THEN - WRITE (*, 304) - STOP - ENDIF + IF (IBRE < 0) RETURN + IF (NE2 > NUMAX) THEN + WRITE (*, 304) + STOP + ENDIF ! - CONE(:,:NE2) = ZERO + CONE(:,:NE2) = ZERO ! - PROC = -CONST/DBLE(KS(1)*KS(2)) + PROC = -CONST/DBLE(KS(1)*KS(2)) ! ! Negative sign arises from Pauli phase factor ! - DO N = 1, NE2 - NU = NE1 + 2*(N - 1) - K = NU - IP = (KS(1)-KS(2))/2 + K - IPP = IP + 1 - IF (NU /= 0) THEN - KK = K + K + 1 - IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN - PROD = PROC - IF (MOD(IP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) - CONE(:3,N) = CONE(:3,N) + PROD*S(:3) - ENDIF -! - K = NU - 1 - KK = K + K + 1 - IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN - PROD = PROC - IF (MOD(IPP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) - CONE(:3,N) = CONE(:3,N) + PROD*S(:3) -! - ENDIF - ENDIF - IF (N == NE2) EXIT - K = NU + 1 - KK = K + K + 1 - PROD = PROC - IF (MOD(IPP,2) /= 0) PROD = -PROD - CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) - IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,7) - CONE(:,N) = CONE(:,N) + PROD*S(:7) - END DO + DO N = 1, NE2 + NU = NE1 + 2*(N - 1) + K = NU + IP = (KS(1)-KS(2))/2 + K + IPP = IP + 1 + IF (NU /= 0) THEN + KK = K + K + 1 + IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN + PROD = PROC + IF (MOD(IP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) + CONE(:3,N) = CONE(:3,N) + PROD*S(:3) + ENDIF +! + K = NU - 1 + KK = K + K + 1 + IF (ITRIG(KS(1),KS(2),KK) /= 0) THEN + PROD = PROC + IF (MOD(IPP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,3) + CONE(:3,N) = CONE(:3,N) + PROD*S(:3) +! + ENDIF + ENDIF + IF (N == NE2) EXIT + K = NU + 1 + KK = K + K + 1 + PROD = PROC + IF (MOD(IPP,2) /= 0) PROD = -PROD + CALL CXK (S, JS, KAPS, NU, K, IBRE, 2) + IF (IBUG2 /= 0) WRITE (99, 303) PROD, (S(MU),MU=1,7) + CONE(:,N) = CONE(:,N) + PROD*S(:7) + END DO ! ! 4.0 Output results ! - DO N = 1, NE2 - NU = NE1 + 2*(N - 1) - ITYPE = ISG*5 - CALL TALK (JA, JB, NU, IB1, IA1, IB1, IA1, ITYPE, CONE(1,N)) - CALL TALK (JA, JB, NU, IA1, IB1, IB1, IA1, ITYPE, CONE(2,N)) - CALL TALK (JA, JB, NU, IA1, IB1, IA1, IB1, ITYPE, CONE(3,N)) - IF (N == NE2) CYCLE - NUP1 = NU + 1 - ITYPE = ISG*6 - CALL TALK (JA, JB, NUP1, IA1, IB1, IA1, IB1, ITYPE, CONE(4,N)) - CALL TALK (JA, JB, NUP1, IB1, IA1, IB1, IA1, ITYPE, CONE(5,N)) - CALL TALK (JA, JB, NUP1, IA1, IB1, IB1, IA1, ITYPE, CONE(6,N)) - CALL TALK (JA, JB, NUP1, IB1, IA1, IA1, IB1, ITYPE, CONE(7,N)) - END DO - RETURN -! - 300 FORMAT('BREID: orbitals ',2I3) - 301 FORMAT(2X,'ND1 ND2 NE1 NE2 IBRD IBRE ',6I5) - 302 FORMAT(2X,'aaaa contribution: NU,GAM,COEF',I5,2(3X,1P,D15.8)) - 303 FORMAT(2X,'PROD = ',1P,D15.8,/,' S',7D15.8) - 304 FORMAT('BREID: Dimension error for NUMAX.') - RETURN -! - END SUBROUTINE BREID + DO N = 1, NE2 + NU = NE1 + 2*(N - 1) + ITYPE = ISG*5 + CALL TALK (JA, JB, NU, IB1, IA1, IB1, IA1, ITYPE, CONE(1,N)) + CALL TALK (JA, JB, NU, IA1, IB1, IB1, IA1, ITYPE, CONE(2,N)) + CALL TALK (JA, JB, NU, IA1, IB1, IA1, IB1, ITYPE, CONE(3,N)) + IF (N == NE2) CYCLE + NUP1 = NU + 1 + ITYPE = ISG*6 + CALL TALK (JA, JB, NUP1, IA1, IB1, IA1, IB1, ITYPE, CONE(4,N)) + CALL TALK (JA, JB, NUP1, IB1, IA1, IB1, IA1, ITYPE, CONE(5,N)) + CALL TALK (JA, JB, NUP1, IA1, IB1, IB1, IA1, ITYPE, CONE(6,N)) + CALL TALK (JA, JB, NUP1, IB1, IA1, IA1, IB1, ITYPE, CONE(7,N)) + END DO + RETURN +! + 300 FORMAT('BREID: orbitals ',2I3) + 301 FORMAT(2X,'ND1 ND2 NE1 NE2 IBRD IBRE ',6I5) + 302 FORMAT(2X,'aaaa contribution: NU,GAM,COEF',I5,2(3X,1P,D15.8)) + 303 FORMAT(2X,'PROD = ',1P,D15.8,/,' S',7D15.8) + 304 FORMAT('BREID: Dimension error for NUMAX.') + RETURN +! + END SUBROUTINE BREID diff --git a/src/appl/rci90_mpi/breid_I.f90 b/src/appl/rci90_mpi/breid_I.f90 index 7d27298c3..b2eb24e5d 100644 --- a/src/appl/rci90_mpi/breid_I.f90 +++ b/src/appl/rci90_mpi/breid_I.f90 @@ -1,14 +1,14 @@ - MODULE breid_I + MODULE breid_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE breid (JA, JB, JA1, IPCA, JB1) - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE breid (JA, JB, JA1, IPCA, JB1) + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/brint1.f90 b/src/appl/rci90_mpi/brint1.f90 index 08affb3b0..b21515d9b 100644 --- a/src/appl/rci90_mpi/brint1.f90 +++ b/src/appl/rci90_mpi/brint1.f90 @@ -7,7 +7,7 @@ SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) ! Written by Per Jonsson Octaober 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint1_I.f90 b/src/appl/rci90_mpi/brint1_I.f90 index eea131bdf..037526de6 100644 --- a/src/appl/rci90_mpi/brint1_I.f90 +++ b/src/appl/rci90_mpi/brint1_I.f90 @@ -1,6 +1,6 @@ - MODULE brint1_I + MODULE brint1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -8,4 +8,4 @@ SUBROUTINE BRINT1 (IA,IB,IC,ID,K,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brint2.f90 b/src/appl/rci90_mpi/brint2.f90 index 8250e4bfd..44f31bd4f 100644 --- a/src/appl/rci90_mpi/brint2.f90 +++ b/src/appl/rci90_mpi/brint2.f90 @@ -7,7 +7,7 @@ SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) ! Written by Per Jonsson Octaober 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint2_I.f90 b/src/appl/rci90_mpi/brint2_I.f90 index 1bdf02286..98be10bd7 100644 --- a/src/appl/rci90_mpi/brint2_I.f90 +++ b/src/appl/rci90_mpi/brint2_I.f90 @@ -1,6 +1,6 @@ - MODULE brint2_I + MODULE brint2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -8,4 +8,4 @@ SUBROUTINE BRINT2 (IA,IB,IC,ID,K,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brint3.f90 b/src/appl/rci90_mpi/brint3.f90 index caf73d6da..9c00630e9 100644 --- a/src/appl/rci90_mpi/brint3.f90 +++ b/src/appl/rci90_mpi/brint3.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint3_I.f90 b/src/appl/rci90_mpi/brint3_I.f90 index 925807a9f..4e1ab8ee8 100644 --- a/src/appl/rci90_mpi/brint3_I.f90 +++ b/src/appl/rci90_mpi/brint3_I.f90 @@ -1,7 +1,7 @@ - MODULE brint3_I + MODULE brint3_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT3 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brint4.f90 b/src/appl/rci90_mpi/brint4.f90 index 23799fb35..5bbba8881 100644 --- a/src/appl/rci90_mpi/brint4.f90 +++ b/src/appl/rci90_mpi/brint4.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint4_I.f90 b/src/appl/rci90_mpi/brint4_I.f90 index 43bd4b3de..6a5d76cd2 100644 --- a/src/appl/rci90_mpi/brint4_I.f90 +++ b/src/appl/rci90_mpi/brint4_I.f90 @@ -1,7 +1,7 @@ - MODULE brint4_I + MODULE brint4_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT4 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brint5.f90 b/src/appl/rci90_mpi/brint5.f90 index 3d2d0296a..97fd7ce45 100644 --- a/src/appl/rci90_mpi/brint5.f90 +++ b/src/appl/rci90_mpi/brint5.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint5_I.f90 b/src/appl/rci90_mpi/brint5_I.f90 index 800cacd8e..74edf74ac 100644 --- a/src/appl/rci90_mpi/brint5_I.f90 +++ b/src/appl/rci90_mpi/brint5_I.f90 @@ -1,7 +1,7 @@ - MODULE brint5_I + MODULE brint5_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT5 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brint6.f90 b/src/appl/rci90_mpi/brint6.f90 index 979f99710..f8b853059 100644 --- a/src/appl/rci90_mpi/brint6.f90 +++ b/src/appl/rci90_mpi/brint6.f90 @@ -16,8 +16,8 @@ SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) ! Written by Farid A Parpia Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/brint6_I.f90 b/src/appl/rci90_mpi/brint6_I.f90 index 155f6ce79..72e457de7 100644 --- a/src/appl/rci90_mpi/brint6_I.f90 +++ b/src/appl/rci90_mpi/brint6_I.f90 @@ -1,7 +1,7 @@ - MODULE brint6_I + MODULE brint6_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) USE vast_kind_param, ONLY: DOUBLE @@ -9,4 +9,4 @@ SUBROUTINE BRINT6 (IA,IB,IC,ID,NU,TEGRAL) REAL(DOUBLE), INTENT(out) :: tegral END SUBROUTINE END INTERFACE - END MODULE + END MODULE diff --git a/src/appl/rci90_mpi/brintf.f90 b/src/appl/rci90_mpi/brintf.f90 index 4229f70cf..9c026266c 100644 --- a/src/appl/rci90_mpi/brintf.f90 +++ b/src/appl/rci90_mpi/brintf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) + REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) ! * ! Computes integrals for the transverse photon interaction. * ! * @@ -9,89 +9,89 @@ REAL(KIND(0.0D0)) FUNCTION BRINTF (ITYPE, IA, IB, IC, ID, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: KEYORB USE stor_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE bessel_I - USE brra_I + USE bessel_I + USE brra_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ITYPE - INTEGER :: IA - INTEGER :: IB - INTEGER :: IC - INTEGER :: ID - INTEGER :: K + INTEGER :: ITYPE + INTEGER :: IA + INTEGER :: IB + INTEGER :: IC + INTEGER :: ID + INTEGER :: K !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- INTEGER, PARAMETER :: KEY = KEYORB - INTEGER, PARAMETER :: KEY2 = KEY*KEY + INTEGER, PARAMETER :: KEY2 = KEY*KEY !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ICOD, ICOD1, ICOD2, ICOD3, ICOD4 + INTEGER :: ICOD, ICOD1, ICOD2, ICOD3, ICOD4 !----------------------------------------------- ! - GO TO (1,4,3,6,2,5) ITYPE + GO TO (1,4,3,6,2,5) ITYPE ! ! Type 1 and 5 integrals require j(k), n(k) Bessel fuctions ! Type 5 integrals only require w = wab Bessel functions ! - 1 CONTINUE + 1 CONTINUE IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC==IB) CALL BESSEL (IC, ID, 1, 2& - , K) - 2 CONTINUE - CALL BESSEL (IA, IB, 1, 1, K) - GO TO 6 + , K) + 2 CONTINUE + CALL BESSEL (IA, IB, 1, 1, K) + GO TO 6 ! ! Type 3 integrals require j(k), n(k) Bessel functions for either ! w = wab or w = cd whichever is non-zero. ! - 3 CONTINUE - IF (IA /= IB) CALL BESSEL (IA, IB, 1, 1, K) - IF (IC /= ID) CALL BESSEL (IC, ID, 1, 2, K) - GO TO 6 + 3 CONTINUE + IF (IA /= IB) CALL BESSEL (IA, IB, 1, 1, K) + IF (IC /= ID) CALL BESSEL (IC, ID, 1, 2, K) + GO TO 6 ! ! Type 2 and 6 integrals require j(k), n(k) and j(k+2), n(k+2) ! Bessel fuctions ! Type 6 integrals only require w = wab Bessel functions. ! - 4 CONTINUE - IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC/=IB) THEN + 4 CONTINUE + IF (IA/=IC .OR. IB/=ID .OR. IA/=ID .OR. IC/=IB) THEN ! - ICOD = MAX(IC,ID) + KEY*MIN(IC,ID) - ICOD1 = ICOD + KEY2*(K - 1) - ICOD2 = ICOD + KEY2*(K + 1) - ICOD = MAX(IA,IB) + KEY*MIN(IA,IB) - ICOD3 = ICOD + KEY2*(K - 1) - ICOD4 = ICOD + KEY2*(K + 1) + ICOD = MAX(IC,ID) + KEY*MIN(IC,ID) + ICOD1 = ICOD + KEY2*(K - 1) + ICOD2 = ICOD + KEY2*(K + 1) + ICOD = MAX(IA,IB) + KEY*MIN(IA,IB) + ICOD3 = ICOD + KEY2*(K - 1) + ICOD4 = ICOD + KEY2*(K + 1) IF (ICOD1==KEEP(1,2) .AND. ICOD2==KEEP(2,2) .AND. ICOD3==KEEP(1,1)& - .AND. ICOD4==KEEP(2,1)) GO TO 6 + .AND. ICOD4==KEEP(2,1)) GO TO 6 IF (ICOD1==KEEP(1,1) .AND. ICOD2==KEEP(2,1) .AND. ICOD3==KEEP(1,2)& - .AND. ICOD4==KEEP(2,2)) GO TO 6 - CALL BESSEL (IC, ID, 1, 2, K - 1) - CALL BESSEL (IC, ID, 2, 2, K + 1) - ENDIF + .AND. ICOD4==KEEP(2,2)) GO TO 6 + CALL BESSEL (IC, ID, 1, 2, K - 1) + CALL BESSEL (IC, ID, 2, 2, K + 1) + ENDIF ! - 5 CONTINUE - CALL BESSEL (IA, IB, 1, 1, K - 1) - CALL BESSEL (IA, IB, 2, 1, K + 1) + 5 CONTINUE + CALL BESSEL (IA, IB, 1, 1, K - 1) + CALL BESSEL (IA, IB, 2, 1, K + 1) ! ! Compute the integral ! - 6 CONTINUE - BRINTF = BRRA(ITYPE,IA,IB,IC,ID,K) + 6 CONTINUE + BRINTF = BRRA(ITYPE,IA,IB,IC,ID,K) ! - RETURN - END FUNCTION BRINTF + RETURN + END FUNCTION BRINTF diff --git a/src/appl/rci90_mpi/brintf_I.f90 b/src/appl/rci90_mpi/brintf_I.f90 index 5d0a847fd..e9de88d61 100644 --- a/src/appl/rci90_mpi/brintf_I.f90 +++ b/src/appl/rci90_mpi/brintf_I.f90 @@ -1,15 +1,15 @@ - MODULE brintf_I + MODULE brintf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION brintf (ITYPE, IA, IB, IC, ID, K) - INTEGER, INTENT(IN) :: ITYPE - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION brintf (ITYPE, IA, IB, IC, ID, K) + INTEGER, INTENT(IN) :: ITYPE + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/brra.f90 b/src/appl/rci90_mpi/brra.f90 index 5fc8f2994..6f22888fa 100644 --- a/src/appl/rci90_mpi/brra.f90 +++ b/src/appl/rci90_mpi/brra.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) + REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) ! * ! This routine evaluates the transverse interaction integrals: * ! * @@ -16,13 +16,13 @@ REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE cons_C USE grid_C @@ -30,97 +30,97 @@ REAL(KIND(0.0D0)) FUNCTION BRRA (ITYPE, IA, IC, IB, ID, K) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rkint_I - USE skint_I + USE rkint_I + USE skint_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: IA - INTEGER :: IC - INTEGER :: IB - INTEGER :: ID - INTEGER :: K + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: IA + INTEGER :: IC + INTEGER :: IB + INTEGER :: ID + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRAC, I, MXRBD - REAL(DOUBLE), DIMENSION(NNNP) :: RAC, RBD + INTEGER :: MXRAC, I, MXRBD + REAL(DOUBLE), DIMENSION(NNNP) :: RAC, RBD !----------------------------------------------- ! - MXRAC = MIN(MF(IA),MF(IC)) - DO I = 1, MXRAC - RAC(I) = PF(I,IA)*QF(I,IC) - END DO + MXRAC = MIN(MF(IA),MF(IC)) + DO I = 1, MXRAC + RAC(I) = PF(I,IA)*QF(I,IC) + END DO ! - MXRBD = MIN(MF(IB),MF(ID)) - DO I = 1, MXRBD - RBD(I) = PF(I,IB)*QF(I,ID) - END DO + MXRBD = MIN(MF(IB),MF(ID)) + DO I = 1, MXRBD + RBD(I) = PF(I,IB)*QF(I,ID) + END DO ! - GO TO (21,22,23,24,25,26) ITYPE + GO TO (21,22,23,24,25,26) ITYPE ! ! ITYPE = 1 ! - 21 CONTINUE - IF (IA==IB .AND. IC==ID) GO TO 9 - IF (IA==ID .AND. IC==IB) GO TO 10 + 21 CONTINUE + IF (IA==IB .AND. IC==ID) GO TO 9 + IF (IA==ID .AND. IC==IB) GO TO 10 BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RAC,IA,IC,RBD,IB,ID,K,2)& + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,2))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 2 ! - 22 CONTINUE - IF (IA==IB .AND. IC==ID) GO TO 26 - IF (IA==ID .AND. IC==IB) GO TO 26 + 22 CONTINUE + IF (IA==IB .AND. IC==ID) GO TO 26 + IF (IA==ID .AND. IC==IB) GO TO 26 BRRA = (SKINT(RAC,IA,IC,RBD,IB,ID,K,1) + SKINT(RAC,IA,IC,RBD,IB,ID,K,2))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 3 ! - 23 CONTINUE - IF (IA == IC) THEN - DO I = 1, MXRBD - RBD(I) = RBD(I) + PF(I,ID)*QF(I,IB) - END DO + 23 CONTINUE + IF (IA == IC) THEN + DO I = 1, MXRBD + RBD(I) = RBD(I) + PF(I,ID)*QF(I,IB) + END DO BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0& ) + RKINT(RAC,IA,IC,RBD,IB,ID,K,2) + RKINT(RBD,IB,ID,RAC,IA,IC,K,2)& - )*HALF - RETURN - ENDIF - DO I = 1, MXRAC - RAC(I) = RAC(I) + PF(I,IC)*QF(I,IA) - END DO + )*HALF + RETURN + ENDIF + DO I = 1, MXRAC + RAC(I) = RAC(I) + PF(I,IC)*QF(I,IA) + END DO BRRA = (RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1)& + RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0))*& - HALF - RETURN + HALF + RETURN ! ! ITYPE = 4 ! - 24 CONTINUE - BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0) - RETURN + 24 CONTINUE + BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,0) + RKINT(RBD,IB,ID,RAC,IA,IC,K,0) + RETURN ! ! ITYPE = 5 ! - 25 CONTINUE - IF (IA==ID .AND. IC==IB) GO TO 10 - 9 CONTINUE - BRRA = TWO*RKINT(RAC,IA,IC,RBD,IB,ID,K,1) - RETURN - 10 CONTINUE - BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) - RETURN + 25 CONTINUE + IF (IA==ID .AND. IC==IB) GO TO 10 + 9 CONTINUE + BRRA = TWO*RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RETURN + 10 CONTINUE + BRRA = RKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RKINT(RBD,IB,ID,RAC,IA,IC,K,1) + RETURN ! ! ITYPE = 6 ! - 26 CONTINUE - BRRA = SKINT(RAC,IA,IC,RBD,IB,ID,K,1) - RETURN + 26 CONTINUE + BRRA = SKINT(RAC,IA,IC,RBD,IB,ID,K,1) + RETURN ! - END FUNCTION BRRA + END FUNCTION BRRA diff --git a/src/appl/rci90_mpi/brra_I.f90 b/src/appl/rci90_mpi/brra_I.f90 index 565cb8063..69a9efeff 100644 --- a/src/appl/rci90_mpi/brra_I.f90 +++ b/src/appl/rci90_mpi/brra_I.f90 @@ -1,15 +1,15 @@ - MODULE brra_I + MODULE brra_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION brra (ITYPE, IA, IC, IB, ID, K) - INTEGER, INTENT(IN) :: ITYPE - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION brra (ITYPE, IA, IC, IB, ID, K) + INTEGER, INTENT(IN) :: ITYPE + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/cxk.f90 b/src/appl/rci90_mpi/cxk.f90 index beb24aada..2ef0a74c0 100644 --- a/src/appl/rci90_mpi/cxk.f90 +++ b/src/appl/rci90_mpi/cxk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) + SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) ! * ! Computes the coefficients of radial integrals in the expansion * ! of the effective interaction strength: X(K,IA1,IB1,IA2,IB2). * @@ -41,241 +41,241 @@ SUBROUTINE CXK(S, IS, KAPS, NU, K, IBR, IEX) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cre_I + USE cre_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NU - INTEGER :: K - INTEGER, INTENT(IN) :: IBR - INTEGER, INTENT(IN) :: IEX - INTEGER, INTENT(IN) :: IS(4) - INTEGER, INTENT(IN) :: KAPS(4) - REAL(DOUBLE), INTENT(INOUT) :: S(12) + INTEGER, INTENT(IN) :: NU + INTEGER :: K + INTEGER, INTENT(IN) :: IBR + INTEGER, INTENT(IN) :: IEX + INTEGER, INTENT(IN) :: IS(4) + INTEGER, INTENT(IN) :: KAPS(4) + REAL(DOUBLE), INTENT(INOUT) :: S(12) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MU, IA, IB, IC, ID, KA, KB, KC, KD, KK, IK, IP + INTEGER :: MU, IA, IB, IC, ID, KA, KB, KC, KD, KK, IK, IP REAL(DOUBLE) :: D, H, DK1, DK2, FK, GK, G1, G2, G3, G4, A, F1, F2, F3, F4& - , B, DK + , B, DK !----------------------------------------------- ! ! ! 1.0 Initialization ! - S = 0.0D00 + S = 0.0D00 ! - IA = IS(1) - IB = IS(2) - IC = IS(3) - ID = IS(4) - KA = KAPS(1)/2 - KB = KAPS(2)/2 - KC = KAPS(3)/2 - KD = KAPS(4)/2 - IF (IEX == 2) THEN - KK = KD - IK = ID - KD = KC - ID = IC - KC = KK - IC = IK - ENDIF - SELECT CASE (IBR) - CASE DEFAULT - GO TO 17 + IA = IS(1) + IB = IS(2) + IC = IS(3) + ID = IS(4) + KA = KAPS(1)/2 + KB = KAPS(2)/2 + KC = KAPS(3)/2 + KD = KAPS(4)/2 + IF (IEX == 2) THEN + KK = KD + IK = ID + KD = KC + ID = IC + KC = KK + IC = IK + ENDIF + SELECT CASE (IBR) + CASE DEFAULT + GO TO 17 ! ! 2.0 IBR = 1 --- The general case ! - CASE (1) - IF (NU - K >= 0) THEN - IF (NU - K <= 0) THEN - S(1) = -(KA + KC)*(KD + KB) - IF (K == 0) GO TO 16 - D = K*(K + 1) - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - S(1) = S(1)*H/D - S(2:4) = S(1) - RETURN - ENDIF + CASE (1) + IF (NU - K >= 0) THEN + IF (NU - K <= 0) THEN + S(1) = -(KA + KC)*(KD + KB) + IF (K == 0) GO TO 16 + D = K*(K + 1) + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + S(1) = S(1)*H/D + S(2:4) = S(1) + RETURN + ENDIF ! ! 2.2 NU = K+1 ! - DK1 = KC - KA - DK2 = KD - KB - FK = K - GK = K + 1 - G1 = DK1 - GK - G2 = DK1 + GK - G3 = DK2 - GK - G4 = DK2 + GK - KK = K + K + 1 - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - A = H*FK/GK/DBLE(KK*(KK + 2)) - S(1) = A*G1*G3 - S(2) = A*G2*G4 - S(3) = A*G1*G4 - S(4) = A*G2*G3 - RETURN - ENDIF + DK1 = KC - KA + DK2 = KD - KB + FK = K + GK = K + 1 + G1 = DK1 - GK + G2 = DK1 + GK + G3 = DK2 - GK + G4 = DK2 + GK + KK = K + K + 1 + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + A = H*FK/GK/DBLE(KK*(KK + 2)) + S(1) = A*G1*G3 + S(2) = A*G2*G4 + S(3) = A*G1*G4 + S(4) = A*G2*G3 + RETURN + ENDIF ! ! 2.2 NU = K-1 ! - DK1 = KC - KA - DK2 = KD - KB - FK = K - GK = K + 1 - F1 = DK1 - FK - F2 = DK1 + FK - F3 = DK2 - FK - F4 = DK2 + FK - G1 = DK1 - GK - G2 = DK1 + GK - G3 = DK2 - GK - G4 = DK2 + GK - KK = K + K + 1 - H = CRE(KA,K,KC)*CRE(KB,K,KD) - IF (MOD(K,2) /= 0) H = -H - A = H*GK/FK/DBLE(KK*(KK - 2)) - S(1) = A*F2*F4 - S(2) = A*F1*F3 - S(3) = A*F2*F3 - S(4) = A*F1*F4 - B = H/DBLE(KK*KK) - S(5) = B*F2*G3 - S(6) = B*F4*G1 - S(7) = B*F1*G4 - S(8) = B*F3*G2 - S(9) = B*F2*G4 - S(10) = B*F3*G1 - S(11) = B*F1*G3 - S(12) = B*F4*G2 - RETURN + DK1 = KC - KA + DK2 = KD - KB + FK = K + GK = K + 1 + F1 = DK1 - FK + F2 = DK1 + FK + F3 = DK2 - FK + F4 = DK2 + FK + G1 = DK1 - GK + G2 = DK1 + GK + G3 = DK2 - GK + G4 = DK2 + GK + KK = K + K + 1 + H = CRE(KA,K,KC)*CRE(KB,K,KD) + IF (MOD(K,2) /= 0) H = -H + A = H*GK/FK/DBLE(KK*(KK - 2)) + S(1) = A*F2*F4 + S(2) = A*F1*F3 + S(3) = A*F2*F3 + S(4) = A*F1*F4 + B = H/DBLE(KK*KK) + S(5) = B*F2*G3 + S(6) = B*F4*G1 + S(7) = B*F1*G4 + S(8) = B*F3*G2 + S(9) = B*F2*G4 + S(10) = B*F3*G1 + S(11) = B*F1*G3 + S(12) = B*F4*G2 + RETURN ! ! 3.0 IBR = 2 Degenerate case: only one non-zero R-integral ! - CASE (2) - IF (IA/=IC .OR. IB==ID) THEN - IF (IA==IC .OR. IB/=ID) GO TO 17 + CASE (2) + IF (IA/=IC .OR. IB==ID) THEN + IF (IA==IC .OR. IB/=ID) GO TO 17 ! - IK = IB - IB = IA - IA = IK - IK = ID - ID = IC - IC = IK + IK = IB + IB = IA + IA = IK + IK = ID + ID = IC + IC = IK ! - KK = KB - KB = KA - KA = KK - KK = KD - KD = KC - KC = KK - ENDIF + KK = KB + KB = KA + KA = KK + KK = KD + KD = KC + KC = KK + ENDIF ! - IF (MOD(K,2) /= 1) RETURN - DK = K*(K + 1) - H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK - S(1) = H*DBLE(4*KA*(KB + KD)) - RETURN + IF (MOD(K,2) /= 1) RETURN + DK = K*(K + 1) + H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK + S(1) = H*DBLE(4*KA*(KB + KD)) + RETURN ! ! 4.0 IBR = 3. Direct magnetic F-integrals ! - CASE (3) - IF (IA/=IC .OR. IB/=ID) GO TO 17 - IF (MOD(K,2) /= 1) RETURN - DK = K*(K + 1) - H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK - S(1) = H*DBLE(16*KA*KB) - RETURN + CASE (3) + IF (IA/=IC .OR. IB/=ID) GO TO 17 + IF (MOD(K,2) /= 1) RETURN + DK = K*(K + 1) + H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK + S(1) = H*DBLE(16*KA*KB) + RETURN ! ! 5.0 IBR = 4. Exchange magnetic G- and H-integrals ! - CASE (4) - IF (IA/=ID .OR. IB/=IC) GO TO 17 - IF (NU - K >= 0) THEN - IF (NU - K <= 0) THEN - S(1) = DBLE(KA + KB)*CRE(KA,K,KB) - IP = ABS(KA) - ABS(KB) + K + 1 - S(1) = S(1)*S(1)/DBLE(K*(K + 1)) - IF (MOD(IP,2) /= 0) S(1) = -S(1) - S(3) = S(1) - S(2) = S(1) + S(1) - RETURN - ENDIF + CASE (4) + IF (IA/=ID .OR. IB/=IC) GO TO 17 + IF (NU - K >= 0) THEN + IF (NU - K <= 0) THEN + S(1) = DBLE(KA + KB)*CRE(KA,K,KB) + IP = ABS(KA) - ABS(KB) + K + 1 + S(1) = S(1)*S(1)/DBLE(K*(K + 1)) + IF (MOD(IP,2) /= 0) S(1) = -S(1) + S(3) = S(1) + S(2) = S(1) + S(1) + RETURN + ENDIF ! ! 5.2 NU = K+1 ! - DK = KB - KA - GK = K + 1 - FK = K - G1 = DK + GK - G2 = DK - GK - KK = K + K + 1 - H = CRE(KA,K,KB)**2 - IF (KA*KB < 0) H = -H - A = H*FK/GK/DBLE(KK*(KK + 2)) - S(1) = -A*G1*G1 - S(2) = -2.0D00*A*G1*G2 - S(3) = -A*G2*G2 - RETURN - ENDIF + DK = KB - KA + GK = K + 1 + FK = K + G1 = DK + GK + G2 = DK - GK + KK = K + K + 1 + H = CRE(KA,K,KB)**2 + IF (KA*KB < 0) H = -H + A = H*FK/GK/DBLE(KK*(KK + 2)) + S(1) = -A*G1*G1 + S(2) = -2.0D00*A*G1*G2 + S(3) = -A*G2*G2 + RETURN + ENDIF ! ! 5.3 NU = K-1 ! - DK = KB - KA - FK = K - GK = K + 1 - F1 = DK + FK - F2 = DK - FK - G1 = DK + GK - G2 = DK - GK - KK = K + K + 1 - H = CRE(KA,K,KB)**2 - IF (KA*KB < 0) H = -H - A = H*GK/FK/DBLE(KK*(KK - 2)) - S(1) = -A*F2*F2 - S(2) = -2.0D00*A*F1*F2 - S(3) = -A*F1*F1 - B = H/DBLE(KK*KK) - B = B + B - S(4) = -B*F1*G2 + DK = KB - KA + FK = K + GK = K + 1 + F1 = DK + FK + F2 = DK - FK + G1 = DK + GK + G2 = DK - GK + KK = K + K + 1 + H = CRE(KA,K,KB)**2 + IF (KA*KB < 0) H = -H + A = H*GK/FK/DBLE(KK*(KK - 2)) + S(1) = -A*F2*F2 + S(2) = -2.0D00*A*F1*F2 + S(3) = -A*F1*F1 + B = H/DBLE(KK*KK) + B = B + B + S(4) = -B*F1*G2 ! S(5) = S(4) - S(5) = -B*F2*G1 - S(6) = -B*F1*G1 - S(7) = -B*F2*G2 - RETURN - END SELECT + S(5) = -B*F2*G1 + S(6) = -B*F1*G1 + S(7) = -B*F2*G2 + RETURN + END SELECT ! ! 6.0 Special cases and errors ! ! Illegal zero value of K in Type 1 ! - 16 CONTINUE - WRITE (*, 300) IS(1), IS(2), IS(3), IS(4), NU, IBR, IEX - STOP + 16 CONTINUE + WRITE (*, 300) IS(1), IS(2), IS(3), IS(4), NU, IBR, IEX + STOP ! ! Illegal combination of states in Type 3 or 4 ! - 17 CONTINUE - WRITE (*, 301) IBR, IS(1), IS(2), IS(3), IS(4), NU, K, IEX - STOP + 17 CONTINUE + WRITE (*, 301) IBR, IS(1), IS(2), IS(3), IS(4), NU, K, IEX + STOP ! - 300 FORMAT('CXK: Illegal value K = 0 -'/,1X,4I3,2X,I3,2X,2I2) - 301 FORMAT('CXK: Type ',I2,'-'/,1X,I2,3X,4I3,2X,2I3,2X,I2) - RETURN + 300 FORMAT('CXK: Illegal value K = 0 -'/,1X,4I3,2X,I3,2X,2I2) + 301 FORMAT('CXK: Type ',I2,'-'/,1X,I2,3X,4I3,2X,2I3,2X,I2) + RETURN ! - END SUBROUTINE CXK + END SUBROUTINE CXK diff --git a/src/appl/rci90_mpi/cxk_I.f90 b/src/appl/rci90_mpi/cxk_I.f90 index be29bee47..a56786814 100644 --- a/src/appl/rci90_mpi/cxk_I.f90 +++ b/src/appl/rci90_mpi/cxk_I.f90 @@ -1,17 +1,17 @@ - MODULE cxk_I + MODULE cxk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IBR - INTEGER, INTENT(IN) :: IEX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IBR + INTEGER, INTENT(IN) :: IEX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/dnicmv.f90 b/src/appl/rci90_mpi/dnicmv.f90 index 4565fdf4a..5f5bb7bb9 100644 --- a/src/appl/rci90_mpi/dnicmv.f90 +++ b/src/appl/rci90_mpi/dnicmv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DNICMV(N, M, B, C) + SUBROUTINE DNICMV(N, M, B, C) ! * ! Matrix-matrix product: C = AB. The lower triangle of the (NxN) * ! matrix is assumed available in packed form in the array EMT. The * @@ -16,95 +16,95 @@ SUBROUTINE DNICMV(N, M, B, C) ! Block version by Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE hmat_C, ONLY: EMT USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dinit_I -! USE dmerge_dnicmv_I + USE dinit_I +! USE dmerge_dnicmv_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M REAL(DOUBLE), DIMENSION(N,M) :: B REAL(DOUBLE), DIMENSION(N,M) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IBEG, IEND, ICOL, NELC, IV - REAL(DOUBLE) :: DIAG, DL + INTEGER :: IBEG, IEND, ICOL, NELC, IV + REAL(DOUBLE) :: DIAG, DL !----------------------------------------------- - + ! Initialise the result matrix; note that this is specific to the ! data structure of DVDSON --- there is no overdimensioning - - CALL DINIT (N*M, 0.0D00, C, 1) - - IBEG = 1 - IEND = 0 - DO ICOL = MYID + 1, N, NPROCS - IEND = IEND + ICOL - NELC = IEND - IBEG + 1 - DO IV = 1, M - DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) + + CALL DINIT (N*M, 0.0D00, C, 1) + + IBEG = 1 + IEND = 0 + DO ICOL = MYID + 1, N, NPROCS + IEND = IEND + ICOL + NELC = IEND - IBEG + 1 + DO IV = 1, M + DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) CALL DMERGE_DNICMV (NELC - 1, B(1:N,IV), C(1:N,IV), & - EMT(IBEG:IEND), B(ICOL,IV), DL) - C(ICOL,IV) = DIAG + DL - END DO - IBEG = IEND + 1 - END DO + EMT(IBEG:IEND), B(ICOL,IV), DL) + C(ICOL,IV) = DIAG + DL + END DO + IBEG = IEND + 1 + END DO CALL gdsummpi (C,N*M) - - RETURN - END SUBROUTINE DNICMV + + RETURN + END SUBROUTINE DNICMV + - !*********************************************************************** ! * - SUBROUTINE DMERGE_DNICMV(N, DB, DC, DA, DCONST, DL) + SUBROUTINE DMERGE_DNICMV(N, DB, DC, DA, DCONST, DL) ! ! Used by dnimcv ! Developed from dmerge. The only diff is: idy not needed here ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: DCONST - REAL(DOUBLE), INTENT(OUT) :: DL + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: DCONST + REAL(DOUBLE), INTENT(OUT) :: DL REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DSUM -!----------------------------------------------- - - DSUM = 0.D0 - DSUM = DOT_PRODUCT(DA,DB(:N)) - DC(:N) = DC(:N) + DCONST*DA - DL = DSUM - - RETURN - END SUBROUTINE DMERGE_DNICMV + INTEGER :: I + REAL(DOUBLE) :: DSUM +!----------------------------------------------- + + DSUM = 0.D0 + DSUM = DOT_PRODUCT(DA,DB(:N)) + DC(:N) = DC(:N) + DCONST*DA + DL = DSUM + + RETURN + END SUBROUTINE DMERGE_DNICMV diff --git a/src/appl/rci90_mpi/dnicmv_I.f90 b/src/appl/rci90_mpi/dnicmv_I.f90 index c01e07782..d9fd62f4e 100644 --- a/src/appl/rci90_mpi/dnicmv_I.f90 +++ b/src/appl/rci90_mpi/dnicmv_I.f90 @@ -1,14 +1,14 @@ - MODULE dnicmv_I + MODULE dnicmv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dnicmv (N, M, B, C) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dnicmv (N, M, B, C) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/dspevx_I.f90 b/src/appl/rci90_mpi/dspevx_I.f90 index 679958024..7c09067c5 100644 --- a/src/appl/rci90_mpi/dspevx_I.f90 +++ b/src/appl/rci90_mpi/dspevx_I.f90 @@ -1,29 +1,29 @@ - MODULE dspevx_I + MODULE dspevx_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE dspevx (JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W& - , Z, LDZ, WORK, IWORK, IFAIL, INFO) - USE vast_kind_param,ONLY: DOUBLE - CHARACTER (LEN = 1) :: JOBZ - CHARACTER (LEN = 1) :: RANGE - CHARACTER (LEN = 1) :: UPLO - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: AP - REAL(DOUBLE), INTENT(IN) :: VL - REAL(DOUBLE), INTENT(IN) :: VU - INTEGER, INTENT(IN) :: IL - INTEGER, INTENT(IN) :: IU - REAL(DOUBLE), INTENT(IN) :: ABSTOL - INTEGER, INTENT(OUT) :: M - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: W - REAL(DOUBLE), DIMENSION(LDZ,*), INTENT(OUT) :: Z - INTEGER, INTENT(IN) :: LDZ - REAL(DOUBLE), DIMENSION(*) :: WORK - INTEGER, DIMENSION(*), INTENT(INOUT) :: IWORK - INTEGER, DIMENSION(*), INTENT(INOUT) :: IFAIL - INTEGER, INTENT(OUT) :: INFO - END SUBROUTINE - END INTERFACE - END MODULE + , Z, LDZ, WORK, IWORK, IFAIL, INFO) + USE vast_kind_param,ONLY: DOUBLE + CHARACTER (LEN = 1) :: JOBZ + CHARACTER (LEN = 1) :: RANGE + CHARACTER (LEN = 1) :: UPLO + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: AP + REAL(DOUBLE), INTENT(IN) :: VL + REAL(DOUBLE), INTENT(IN) :: VU + INTEGER, INTENT(IN) :: IL + INTEGER, INTENT(IN) :: IU + REAL(DOUBLE), INTENT(IN) :: ABSTOL + INTEGER, INTENT(OUT) :: M + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: W + REAL(DOUBLE), DIMENSION(LDZ,*), INTENT(OUT) :: Z + INTEGER, INTENT(IN) :: LDZ + REAL(DOUBLE), DIMENSION(*) :: WORK + INTEGER, DIMENSION(*), INTENT(INOUT) :: IWORK + INTEGER, DIMENSION(*), INTENT(INOUT) :: IFAIL + INTEGER, INTENT(OUT) :: INFO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/engout.f90 b/src/appl/rci90_mpi/engout.f90 index 9300028f9..432c3e581 100644 --- a/src/appl/rci90_mpi/engout.f90 +++ b/src/appl/rci90_mpi/engout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) + SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,87 +13,87 @@ SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE jlabl_C, labj=>jlbr, labp=>jlbp IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JTOT - INTEGER, INTENT(IN) :: IPAR - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - REAL(DOUBLE), INTENT(IN) :: EAV + INTEGER, INTENT(IN) :: JTOT + INTEGER, INTENT(IN) :: IPAR + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + REAL(DOUBLE), INTENT(IN) :: EAV INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO + WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR + 3)/2 - WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR + 3)/2 + WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,2X,2A4,1P,3D22.14) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,2X,2A4,1P,3D22.14) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUT + END SUBROUTINE ENGOUT diff --git a/src/appl/rci90_mpi/engout_I.f90 b/src/appl/rci90_mpi/engout_I.f90 index df0bdbe27..47d7a0bcc 100644 --- a/src/appl/rci90_mpi/engout_I.f90 +++ b/src/appl/rci90_mpi/engout_I.f90 @@ -1,17 +1,17 @@ - MODULE engout_I + MODULE engout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, INTENT(IN) :: JTOT - INTEGER, INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, INTENT(IN) :: JTOT + INTEGER, INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/evcout.f90 b/src/appl/rci90_mpi/evcout.f90 index 1d08e9535..459b7cdc1 100644 --- a/src/appl/rci90_mpi/evcout.f90 +++ b/src/appl/rci90_mpi/evcout.f90 @@ -9,8 +9,8 @@ SUBROUTINE EVCOUT ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -18,7 +18,7 @@ SUBROUTINE EVCOUT USE vast_kind_param, ONLY: DOUBLE USE memory_man USE eigv_C - USE orb_C, ONLY: ncf, nw, iqa + USE orb_C, ONLY: ncf, nw, iqa USE prnt_C IMPLICIT NONE !----------------------------------------------- diff --git a/src/appl/rci90_mpi/funk.f90 b/src/appl/rci90_mpi/funk.f90 index 644a5542d..f644b62d7 100644 --- a/src/appl/rci90_mpi/funk.f90 +++ b/src/appl/rci90_mpi/funk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) + REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) ! * ! This function evaluates the KN(X) functions using the analytic * ! functions defined in tables 1 and 3 of Fullerton and Rinker. * @@ -8,29 +8,29 @@ REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: X !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(4) :: NP - INTEGER :: K, NN, I - REAL(DOUBLE), DIMENSION(10,4) :: P - REAL(DOUBLE), DIMENSION(2,4) :: B - REAL(DOUBLE), DIMENSION(3,4) :: C - REAL(DOUBLE), DIMENSION(5,4) :: D, E - REAL(DOUBLE) :: XN, SUM, X2, BSUM, CSUM, DSUM, ESUM, XM + INTEGER, DIMENSION(4) :: NP + INTEGER :: K, NN, I + REAL(DOUBLE), DIMENSION(10,4) :: P + REAL(DOUBLE), DIMENSION(2,4) :: B + REAL(DOUBLE), DIMENSION(3,4) :: C + REAL(DOUBLE), DIMENSION(5,4) :: D, E + REAL(DOUBLE) :: XN, SUM, X2, BSUM, CSUM, DSUM, ESUM, XM !----------------------------------------------- ! ! @@ -45,104 +45,104 @@ REAL(KIND(0.0D0)) FUNCTION FUNK (X, N) -2.3969236620D-04, 0.0D00, 6.0000000002D00, -6.4305200000D-08, & 2.1049413000D-06, -2.6711271500D-05, -1.3705236152D-01, & -6.3476104090D-04, -7.8739801501D-02, -1.9641740173D-03, & - -3.4752369349D-03, - 7.3145316220D-04/ + -3.4752369349D-03, - 7.3145316220D-04/ ! DATA B/ -3.19999594323D+02, 2.53900995981D00, -6.40514843293D+01, & 7.11722714285D-01, 5.19010136460D+03, 8.28495496200D+01, & - 3.18150793824D+02, 4.33898867347D+01/ + 3.18150793824D+02, 4.33898867347D+01/ ! DATA C/ -3.19999594333D+02, 2.53901020662D+00, 0.0D00, 6.40514843287D+01& , -7.11722686403D-01, 8.042207748D-04, 2.76805406060D+04, & -3.27039477790D+02, 0.0D00, 8.48402116837D+02, -2.56939867765D+01, & - 3.20844906346D-01/ + 3.20844906346D-01/ ! DATA D/ 5.018065179D+00, 7.151891262D+01, 2.116209929D+02, & 3.140327478D+01, -1.0D00, 2.172386409D+02, 1.643364528D+03, & 2.122244512D+03, -4.512004044D+01, 1.0D00, 8.540770444D00, & 6.076242766D+01, 9.714630584D+01, 3.154973593D+01, 1.0D00, & 5.9243015865D-01, 2.0596312871D00, 3.7785190424D00, 3.5614853214D00, & - 1.0D00/ + 1.0D00/ ! DATA E/ 2.669207401D+00, 5.172549669D+01, 2.969809720D+02, & 5.364324164D+02, 1.535335924D+02, 1.155589983D+02, 1.292191441D+03, & 3.831198012D+03, 2.904410075D+03, 0.0D00, 4.543392478D00, & 3.514920169D+01, 6.019668656D+01, 8.468839579D00, 0.0D00, & 3.1511867816D-01, 3.473245222D-01, 3.8791936870D-02, -1.3059741497D-03& - , 0.0D00/ -! - DATA NP/ 8, 8, 9, 10/ -! - IF (X /= 0.0D00) THEN - IF (N<0 .OR. N==2 .OR. N==4 .OR. N>5) GO TO 98 - IF (N - 3 <= 0) THEN - IF (N - 3 /= 0) THEN - K = N + 1 - XN = 1.0D00 - GO TO 4 - ENDIF - K = N - XN = 1.0D00/X**2 - GO TO 4 - ENDIF - K = N - 1 - XN = 1.0D00/X**4 - 4 CONTINUE - IF (X <= 1.0D00) THEN + , 0.0D00/ +! + DATA NP/ 8, 8, 9, 10/ +! + IF (X /= 0.0D00) THEN + IF (N<0 .OR. N==2 .OR. N==4 .OR. N>5) GO TO 98 + IF (N - 3 <= 0) THEN + IF (N - 3 /= 0) THEN + K = N + 1 + XN = 1.0D00 + GO TO 4 + ENDIF + K = N + XN = 1.0D00/X**2 + GO TO 4 + ENDIF + K = N - 1 + XN = 1.0D00/X**4 + 4 CONTINUE + IF (X <= 1.0D00) THEN ! ! Calculate function for X < = 1 ! - NN = NP(K) - SUM = 0.0D00 - DO I = 1, NN - SUM = SUM + P(I,K)*XN - XN = XN*X - END DO - X2 = X*X - BSUM = B(1,K) + X2*(B(2,K)+X2) - CSUM = C(1,K) + X2*(C(2,K)+X2*C(3,K)) - GO TO (6,8,7,8) K - 6 CONTINUE - BSUM = BSUM*X - GO TO 8 - 7 CONTINUE - BSUM = BSUM*X2 - 8 CONTINUE - SUM = SUM + BSUM*DLOG(X)/CSUM - FUNK = SUM - RETURN - ENDIF + NN = NP(K) + SUM = 0.0D00 + DO I = 1, NN + SUM = SUM + P(I,K)*XN + XN = XN*X + END DO + X2 = X*X + BSUM = B(1,K) + X2*(B(2,K)+X2) + CSUM = C(1,K) + X2*(C(2,K)+X2*C(3,K)) + GO TO (6,8,7,8) K + 6 CONTINUE + BSUM = BSUM*X + GO TO 8 + 7 CONTINUE + BSUM = BSUM*X2 + 8 CONTINUE + SUM = SUM + BSUM*DLOG(X)/CSUM + FUNK = SUM + RETURN + ENDIF ! ! Calculate function for X > 1 ! - XN = 1.0D00 - DSUM = 0.0D00 - ESUM = 0.0D00 - DO I = 1, 5 - DSUM = DSUM + D(I,K)*XN - ESUM = ESUM + E(I,K)*XN - XN = XN/X - END DO - XM = -X - SUM = DSUM*EXP(XM)/(ESUM*DSQRT(X**3)) - FUNK = SUM - RETURN - ENDIF - IF (N /= 0) GO TO 99 - FUNK = P(1,1) - RETURN + XN = 1.0D00 + DSUM = 0.0D00 + ESUM = 0.0D00 + DO I = 1, 5 + DSUM = DSUM + D(I,K)*XN + ESUM = ESUM + E(I,K)*XN + XN = XN/X + END DO + XM = -X + SUM = DSUM*EXP(XM)/(ESUM*DSQRT(X**3)) + FUNK = SUM + RETURN + ENDIF + IF (N /= 0) GO TO 99 + FUNK = P(1,1) + RETURN ! ! Error section ! - 98 CONTINUE - WRITE (*, 302) - STOP - 99 CONTINUE - WRITE (*, 301) - STOP + 98 CONTINUE + WRITE (*, 302) + STOP + 99 CONTINUE + WRITE (*, 301) + STOP ! - 301 FORMAT(/,' Attempt to calculate FUNK (0,N) for N > 0') + 301 FORMAT(/,' Attempt to calculate FUNK (0,N) for N > 0') 302 FORMAT(/,' Attempt to calculate FUNK (X,N) for N other than',& - ' 0, 1, 3 and 5.') - RETURN + ' 0, 1, 3 and 5.') + RETURN ! - END FUNCTION FUNK + END FUNCTION FUNK diff --git a/src/appl/rci90_mpi/funk_I.f90 b/src/appl/rci90_mpi/funk_I.f90 index 38538fdb5..0e9a4de5d 100644 --- a/src/appl/rci90_mpi/funk_I.f90 +++ b/src/appl/rci90_mpi/funk_I.f90 @@ -1,13 +1,13 @@ - MODULE funk_I + MODULE funk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION funk (X, N) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: X - INTEGER, INTENT(IN) :: N + REAL(KIND(0.0D0)) FUNCTION funk (X, N) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: N !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/funl.f90 b/src/appl/rci90_mpi/funl.f90 index 04030f1e9..f7b364bae 100644 --- a/src/appl/rci90_mpi/funl.f90 +++ b/src/appl/rci90_mpi/funl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) + REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) ! * ! This function evaluates the LK(X) functions using the analytic * ! functions defined in table 5 and equations (20) and (21) of * @@ -9,92 +9,92 @@ REAL(KIND(0.0D0)) FUNCTION FUNL (X, K) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(IN) :: X !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K1, I - REAL(DOUBLE), DIMENSION(6,2) :: F - REAL(DOUBLE), DIMENSION(3,2) :: G - REAL(DOUBLE), DIMENSION(2,2) :: H - REAL(DOUBLE) :: A, B, SUM, XN, X2, SUMG, SUMH, XM + INTEGER :: K1, I + REAL(DOUBLE), DIMENSION(6,2) :: F + REAL(DOUBLE), DIMENSION(3,2) :: G + REAL(DOUBLE), DIMENSION(2,2) :: H + REAL(DOUBLE) :: A, B, SUM, XN, X2, SUMG, SUMH, XM !----------------------------------------------- ! ! DATA F/ 2.008188D00, -2.397605D00, 1.046471D00, -3.670660D-01, & 6.374000D-02, -3.705800D-02, 1.646407D00, -2.092942D00, 9.623100D-01, & - -2.549600D-01, 1.644040D-01, 0.0D00/ + -2.549600D-01, 1.644040D-01, 0.0D00/ ! DATA G/ 7.51198D-01, 1.38889D-01, 2.0886D-02, 1.37691D-01, -4.16667D-01, & - - 9.7486D-02/ + - 9.7486D-02/ ! - DATA H/ -4.44444D-01, -3.472D-03, 4.44444D-01, 1.7361D-02/ + DATA H/ -4.44444D-01, -3.472D-03, 4.44444D-01, 1.7361D-02/ ! - DATA A, B/ 2.2D00, - 1.72D00/ + DATA A, B/ 2.2D00, - 1.72D00/ ! - IF (K>=0 .AND. K<=1) THEN - IF (X <= 2.0D00) THEN - IF (X == 0.0D00) GO TO 6 + IF (K>=0 .AND. K<=1) THEN + IF (X <= 2.0D00) THEN + IF (X == 0.0D00) GO TO 6 ! ! Use rational approximation for X < 2 ! - K1 = K + 1 - SUM = 0.0D00 - XN = 1.0D00 - DO I = 1, 6 - SUM = SUM + XN*F(I,K1) - XN = XN*X - END DO - X2 = X*X - SUMG = G(1,K1) + X2*(G(2,K1)+X2*G(3,K1)) - SUMH = H(1,K1) + X2*X2*H(2,K1) - XN = DLOG(X) - SUMG = XN*(SUMG + XN*SUMH) - IF (K /= 0) THEN - SUM = SUM + SUMG - GO TO 7 - ENDIF - SUM = SUM + X*SUMG - GO TO 7 - ENDIF + K1 = K + 1 + SUM = 0.0D00 + XN = 1.0D00 + DO I = 1, 6 + SUM = SUM + XN*F(I,K1) + XN = XN*X + END DO + X2 = X*X + SUMG = G(1,K1) + X2*(G(2,K1)+X2*G(3,K1)) + SUMH = H(1,K1) + X2*X2*H(2,K1) + XN = DLOG(X) + SUMG = XN*(SUMG + XN*SUMH) + IF (K /= 0) THEN + SUM = SUM + SUMG + GO TO 7 + ENDIF + SUM = SUM + X*SUMG + GO TO 7 + ENDIF ! - SUM = A + B/X - IF (K /= 0) SUM = SUM + (SUM + B/X)/X - SUM = SUM/X - XM = -X - SUM = SUM*DEXP(XM) - GO TO 7 - 6 CONTINUE - IF (K == 1) GO TO 98 - SUM = F(1,1) - 7 CONTINUE - FUNL = SUM - RETURN + SUM = A + B/X + IF (K /= 0) SUM = SUM + (SUM + B/X)/X + SUM = SUM/X + XM = -X + SUM = SUM*DEXP(XM) + GO TO 7 + 6 CONTINUE + IF (K == 1) GO TO 98 + SUM = F(1,1) + 7 CONTINUE + FUNL = SUM + RETURN ! ! Error section ! - 98 CONTINUE - WRITE (*, 302) - STOP - ENDIF - WRITE (*, 301) - STOP + 98 CONTINUE + WRITE (*, 302) + STOP + ENDIF + WRITE (*, 301) + STOP ! - 301 FORMAT(/,'FUNL: K must be either 0 or 1') + 301 FORMAT(/,'FUNL: K must be either 0 or 1') 302 FORMAT(/,'FUNL: Attempt to calculate function for'/,& - ' zero argument and K value of 1') - RETURN + ' zero argument and K value of 1') + RETURN ! - END FUNCTION FUNL + END FUNCTION FUNL diff --git a/src/appl/rci90_mpi/funl_I.f90 b/src/appl/rci90_mpi/funl_I.f90 index f30cdf39d..a35832f88 100644 --- a/src/appl/rci90_mpi/funl_I.f90 +++ b/src/appl/rci90_mpi/funl_I.f90 @@ -1,13 +1,13 @@ - MODULE funl_I + MODULE funl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION funl (X, K) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: X - INTEGER, INTENT(IN) :: K + REAL(KIND(0.0D0)) FUNCTION funl (X, K) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: K !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/fzalf.f90 b/src/appl/rci90_mpi/fzalf.f90 index 91ba279e6..c6422f82e 100644 --- a/src/appl/rci90_mpi/fzalf.f90 +++ b/src/appl/rci90_mpi/fzalf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) ! * ! An estimate of the function F (Z*\alpha) is computed here. * ! * @@ -9,44 +9,44 @@ REAL(KIND(0.0D0)) FUNCTION FZALF (N, KAPPA, Z) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1990 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE mohr_I - USE klamaq_I + USE mohr_I + USE klamaq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: KAPPA - REAL(DOUBLE) :: Z + INTEGER :: N + INTEGER :: KAPPA + REAL(DOUBLE) :: Z !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEFF - REAL(DOUBLE) :: VALUE + INTEGER :: NEFF + REAL(DOUBLE) :: VALUE !----------------------------------------------- ! - IF (N <= 2) THEN - CALL MOHR (N, KAPPA, Z, VALUE) - ELSE - IF (KAPPA==(-1) .OR. KAPPA==1 .OR. KAPPA==(-2)) THEN - NEFF = 2 - CALL MOHR (NEFF, KAPPA, Z, VALUE) - ELSE - CALL KLAMAQ (N, KAPPA, Z, VALUE) - ENDIF - ENDIF + IF (N <= 2) THEN + CALL MOHR (N, KAPPA, Z, VALUE) + ELSE + IF (KAPPA==(-1) .OR. KAPPA==1 .OR. KAPPA==(-2)) THEN + NEFF = 2 + CALL MOHR (NEFF, KAPPA, Z, VALUE) + ELSE + CALL KLAMAQ (N, KAPPA, Z, VALUE) + ENDIF + ENDIF ! - FZALF = VALUE + FZALF = VALUE ! - RETURN - END FUNCTION FZALF + RETURN + END FUNCTION FZALF diff --git a/src/appl/rci90_mpi/fzalf_I.f90 b/src/appl/rci90_mpi/fzalf_I.f90 index 63a53ef65..b35b837fa 100644 --- a/src/appl/rci90_mpi/fzalf_I.f90 +++ b/src/appl/rci90_mpi/fzalf_I.f90 @@ -1,13 +1,13 @@ - MODULE fzalf_I + MODULE fzalf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION fzalf (N, KAPPA, Z) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION fzalf (N, KAPPA, Z) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/gdsummpi_I.f90 b/src/appl/rci90_mpi/gdsummpi_I.f90 index d2781f8e7..b9a608398 100644 --- a/src/appl/rci90_mpi/gdsummpi_I.f90 +++ b/src/appl/rci90_mpi/gdsummpi_I.f90 @@ -1,11 +1,11 @@ - MODULE genintrk_I + MODULE genintrk_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintrk (myid, nprocs, N, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER, INTENT(OUT) :: N, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintbreit1.f90 b/src/appl/rci90_mpi/genintbreit1.f90 index 77b7a54ac..ace21a614 100644 --- a/src/appl/rci90_mpi/genintbreit1.f90 +++ b/src/appl/rci90_mpi/genintbreit1.f90 @@ -17,7 +17,7 @@ SUBROUTINE genintbreit1 (myid, nprocs, NB, j2max) ! Written by Per Jonsson October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/genintbreit1_I.f90 b/src/appl/rci90_mpi/genintbreit1_I.f90 index 11e494a00..2c2d3d42a 100644 --- a/src/appl/rci90_mpi/genintbreit1_I.f90 +++ b/src/appl/rci90_mpi/genintbreit1_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit1_I + MODULE genintbreit1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit1 (myid, nprocs, NB, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: NB, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintbreit1wrap.f90 b/src/appl/rci90_mpi/genintbreit1wrap.f90 index 453e11e97..9ea632f03 100644 --- a/src/appl/rci90_mpi/genintbreit1wrap.f90 +++ b/src/appl/rci90_mpi/genintbreit1wrap.f90 @@ -5,7 +5,7 @@ SUBROUTINE genintbreit1wrap (myid, nprocs, j2max) ! Written by Per Jonsson Last revision: October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/genintbreit1wrap_I.f90 b/src/appl/rci90_mpi/genintbreit1wrap_I.f90 index 03a91b57b..38070ab15 100644 --- a/src/appl/rci90_mpi/genintbreit1wrap_I.f90 +++ b/src/appl/rci90_mpi/genintbreit1wrap_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit1wrap_I + MODULE genintbreit1wrap_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit1wrap (myid, nprocs, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintbreit2.f90 b/src/appl/rci90_mpi/genintbreit2.f90 index 97ee2bf58..170da493e 100644 --- a/src/appl/rci90_mpi/genintbreit2.f90 +++ b/src/appl/rci90_mpi/genintbreit2.f90 @@ -17,7 +17,7 @@ SUBROUTINE genintbreit2 (myid, nprocs, NB, j2max) ! Written by Per Jonsson October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/genintbreit2_I.f90 b/src/appl/rci90_mpi/genintbreit2_I.f90 index 2689029e6..b6d801855 100644 --- a/src/appl/rci90_mpi/genintbreit2_I.f90 +++ b/src/appl/rci90_mpi/genintbreit2_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit2_I + MODULE genintbreit2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit2 (myid, nprocs, NB, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: NB, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintbreit2wrap.f90 b/src/appl/rci90_mpi/genintbreit2wrap.f90 index d06d7a523..27660c418 100644 --- a/src/appl/rci90_mpi/genintbreit2wrap.f90 +++ b/src/appl/rci90_mpi/genintbreit2wrap.f90 @@ -5,7 +5,7 @@ SUBROUTINE genintbreit2wrap (myid, nprocs, j2max) ! Written by Per Jonsson Last revision: October 2014 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/genintbreit2wrap_I.f90 b/src/appl/rci90_mpi/genintbreit2wrap_I.f90 index c0170a969..5c3a17f9f 100644 --- a/src/appl/rci90_mpi/genintbreit2wrap_I.f90 +++ b/src/appl/rci90_mpi/genintbreit2wrap_I.f90 @@ -1,10 +1,10 @@ - MODULE genintbreit2wrap_I + MODULE genintbreit2wrap_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintbreit2wrap (myid, nprocs, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER :: j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintrk.f90 b/src/appl/rci90_mpi/genintrk.f90 index 6963bde26..2e7ab60a1 100644 --- a/src/appl/rci90_mpi/genintrk.f90 +++ b/src/appl/rci90_mpi/genintrk.f90 @@ -15,8 +15,8 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) ! MPI version by Xinghong He Last revision: 22 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -43,7 +43,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) LOGICAL :: GEN,TRIANGRK INTEGER :: key, i, k, ia, ib, ic, id !----------------------------------------------------------------------- - + KEY = NW + 1 KSTART(0) = 1 ! @@ -53,7 +53,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) DO I = 2, NW IF (NKJ(I) .GT. J2MAX) J2MAX = NKJ(I) ENDDO - + IF (J2MAX .GT. KMAX) THEN STOP 'genintrk: KMAX too small' ENDIF @@ -62,7 +62,7 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) ! When GEN is false, sweep through to find dimension ! GEN = .FALSE. - + 999 N = 0 DO K = 0, J2MAX DO IA = 1, NW @@ -90,20 +90,20 @@ SUBROUTINE genintrk (myid, nprocs, N, j2max) IF (.NOT. GEN) THEN CALL ALLOC (INDTEIRK,N,'INDTEIRK', 'GENINTRK') CALL ALLOC (VALTEIRK,N,'VALTEIRK', 'GENINTRK') - + ! Initialization is necessary in the mpi version - + DO i = 1, N INDTEIRK(i) = 0 VALTEIRK(i) = 0.d0 ENDDO - + IF (myid .EQ. 0) & PRINT *, 'Allocating space for ',N,' Rk integrals' - + GEN = .TRUE. GOTO 999 ENDIF - + RETURN END diff --git a/src/appl/rci90_mpi/genintrk_I.f90 b/src/appl/rci90_mpi/genintrk_I.f90 index d2781f8e7..b9a608398 100644 --- a/src/appl/rci90_mpi/genintrk_I.f90 +++ b/src/appl/rci90_mpi/genintrk_I.f90 @@ -1,11 +1,11 @@ - MODULE genintrk_I + MODULE genintrk_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE genintrk (myid, nprocs, N, j2max) INTEGER, INTENT(IN) :: myid, nprocs INTEGER, INTENT(OUT) :: N, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genintrkwrap.f90 b/src/appl/rci90_mpi/genintrkwrap.f90 index 42e18c84d..c24569e9b 100644 --- a/src/appl/rci90_mpi/genintrkwrap.f90 +++ b/src/appl/rci90_mpi/genintrkwrap.f90 @@ -1,40 +1,40 @@ !*********************************************************************** ! * - SUBROUTINE GENINTRKWRAP(MYID, NPROCS, J2MAX) + SUBROUTINE GENINTRKWRAP(MYID, NPROCS, J2MAX) ! ! Written by Xinghong He Last revision: 12 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:42:46 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:42:46 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE CTEILSRK_C + USE CTEILSRK_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE genintrk_I + USE genintrk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: MYID - INTEGER :: NPROCS - INTEGER :: J2MAX + INTEGER :: MYID + INTEGER :: NPROCS + INTEGER :: J2MAX !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: N !----------------------------------------------- - - CALL GENINTRK (MYID, NPROCS, N, J2MAX) - + + CALL GENINTRK (MYID, NPROCS, N, J2MAX) + ! Gather integrals (and their indeces) from- and send to- all nodes - - CALL GISUMMPI (INDTEIRK, N) - CALL GDSUMMPI (VALTEIRK, N) - - RETURN - END SUBROUTINE GENINTRKWRAP + + CALL GISUMMPI (INDTEIRK, N) + CALL GDSUMMPI (VALTEIRK, N) + + RETURN + END SUBROUTINE GENINTRKWRAP diff --git a/src/appl/rci90_mpi/genintrkwrap_I.f90 b/src/appl/rci90_mpi/genintrkwrap_I.f90 index 86ccd2e55..ead56bb71 100644 --- a/src/appl/rci90_mpi/genintrkwrap_I.f90 +++ b/src/appl/rci90_mpi/genintrkwrap_I.f90 @@ -1,12 +1,12 @@ - MODULE genintrkwrap_I + MODULE genintrkwrap_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genintrkwrap (MYID, NPROCS, J2MAX) - INTEGER :: MYID - INTEGER :: NPROCS - INTEGER :: J2MAX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE genintrkwrap (MYID, NPROCS, J2MAX) + INTEGER :: MYID + INTEGER :: NPROCS + INTEGER :: J2MAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genmat.f90 b/src/appl/rci90_mpi/genmat.f90 index 858d19530..00ea954b2 100644 --- a/src/appl/rci90_mpi/genmat.f90 +++ b/src/appl/rci90_mpi/genmat.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) + SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) ! ! Generate Hamiltonian matrix for all blocks ! This routine calls setham to do the computation. It makes @@ -13,13 +13,13 @@ SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) ! Xinghong He 1998-06-23 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE eigv_C USE iccu_C USE orb_C @@ -30,101 +30,101 @@ SUBROUTINE GENMAT(ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE posfile_I - USE setham_I + USE posfile_I + USE setham_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JBLOCK - INTEGER :: MYID - INTEGER :: NPROCS - INTEGER, INTENT(OUT) :: IRESTART - REAL(DOUBLE) :: ATWINV - REAL(DOUBLE) :: ELSTO + INTEGER :: JBLOCK + INTEGER :: MYID + INTEGER :: NPROCS + INTEGER, INTENT(OUT) :: IRESTART + REAL(DOUBLE) :: ATWINV + REAL(DOUBLE) :: ELSTO REAL(DOUBLE), DIMENSION(*) :: SLF_EN !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IREAD, IOS, NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM, I, & - IOS2, NELC, IR, IROWDUM, IPOS, NROWS, J, ICSTRT + IOS2, NELC, IR, IROWDUM, IPOS, NROWS, J, ICSTRT REAL(DOUBLE) :: STOEL, DUM, EAV0 !----------------------------------------------- ! - NELMNT = 0 ! Counting continues in setham - EAV = 0.D0 - ELSTO = 0.D0 - + NELMNT = 0 ! Counting continues in setham + EAV = 0.D0 + ELSTO = 0.D0 + ! See how much had been done (Hamiltonian matrix) ! irestart is set; ! iread accumulated; ! nelmnt, eav, elsto obtained (to be further modified in setham) - - IREAD = 0 ! # of rows read, initialization necessary - - READ (IMCDF, IOSTAT=IOS) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM - IRESTART = IOS - - IF (IOS == 0) THEN - + + IREAD = 0 ! # of rows read, initialization necessary + + READ (IMCDF, IOSTAT=IOS) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + IRESTART = IOS + + IF (IOS == 0) THEN + IF (NCF/=NCFDUM .OR. ICCUT(1)/=ICCUTDUM .OR. MYID/=MYIDDUM .OR. & - NPROCS/= NPROCSDUM) THEN + NPROCS/= NPROCSDUM) THEN WRITE (ISTDE, *) NCF, NCFDUM, ICCUT(1), ICCUTDUM, MYID, MYIDDUM, & - NPROCS, NPROCSDUM, 'check' - STOP 'genmat:1' - ENDIF - - DO I = MYID + 1, NCF, NPROCS + NPROCS, NPROCSDUM, 'check' + STOP 'genmat:1' + ENDIF + + DO I = MYID + 1, NCF, NPROCS READ (IMCDF, IOSTAT=IOS2) NELC, STOEL, (DUM,IR=2,NELC), EAV0, (& - IROWDUM,IR=1,NELC) + IROWDUM,IR=1,NELC) ! Lower triangle row-mode, diagonal last - IF (IOS2 == 0) THEN - IREAD = IREAD + 1 - NELMNT = NELMNT + NELC - EAV = EAV + EAV0 - ELSTO = STOEL - ELSE - EXIT - ENDIF - END DO - IPOS = 7 + NW + NW + IREAD + 1 - ELSE - IPOS = 7 + NW + NW - ENDIF - + IF (IOS2 == 0) THEN + IREAD = IREAD + 1 + NELMNT = NELMNT + NELC + EAV = EAV + EAV0 + ELSTO = STOEL + ELSE + EXIT + ENDIF + END DO + IPOS = 7 + NW + NW + IREAD + 1 + ELSE + IPOS = 7 + NW + NW + ENDIF + ! Find the maximum number of rows - - NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS - IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) - + + NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS + IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) + ! Report the number of rows read. ! A more suitable report on all nodes can be done here, but this will ! set a synchronization point. - - WRITE (ISTDE, *) IREAD, ' (total ', NROWS, ') rows read from .res' + + WRITE (ISTDE, *) IREAD, ' (total ', NROWS, ') rows read from .res' IF (MYID == 0) WRITE (24, *) IREAD, ' (total ', NROWS, & - ') rows read from .res' - + ') rows read from .res' + ! Position the file for the next record from setham - - DO I = 1, JBLOCK - 1 - J = (NCFBLK(I) - MYID - 1 + NPROCS)/NPROCS - IF (NCFBLK(I) < NPROCS) J = NCFBLK(I)/(MYID + 1) - IPOS = IPOS + J + 1 - END DO - CALL POSFILE (0, IMCDF, IPOS) - - IF (IOS /= 0) WRITE (IMCDF) NCF, ICCUT(1), MYID, NPROCS - - IF (IREAD < NROWS) THEN - ICSTRT = IREAD*NPROCS + MYID + 1 + + DO I = 1, JBLOCK - 1 + J = (NCFBLK(I) - MYID - 1 + NPROCS)/NPROCS + IF (NCFBLK(I) < NPROCS) J = NCFBLK(I)/(MYID + 1) + IPOS = IPOS + J + 1 + END DO + CALL POSFILE (0, IMCDF, IPOS) + + IF (IOS /= 0) WRITE (IMCDF) NCF, ICCUT(1), MYID, NPROCS + + IF (IREAD < NROWS) THEN + ICSTRT = IREAD*NPROCS + MYID + 1 ! ...Generate the rest of the Hamiltonian matrix CALL SETHAM (MYID, NPROCS, JBLOCK, ELSTO, ICSTRT, NELMNT, ATWINV, & - SLF_EN) - ELSE - NELMNTTMP = NELMNT - NCFTMP = NCF - ENDIF - - RETURN - END SUBROUTINE GENMAT + SLF_EN) + ELSE + NELMNTTMP = NELMNT + NCFTMP = NCF + ENDIF + + RETURN + END SUBROUTINE GENMAT diff --git a/src/appl/rci90_mpi/genmat2.f90 b/src/appl/rci90_mpi/genmat2.f90 index 0d3565531..f4a8308df 100644 --- a/src/appl/rci90_mpi/genmat2.f90 +++ b/src/appl/rci90_mpi/genmat2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) + SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! ! Get eav and do writings to the summary file .csum ! The mpi version (genmat2mpi) also gets nelmnt_a and elsto @@ -8,11 +8,11 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! Xinghong He 98-06-15 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE, LONG USE hmat_C !! rather than setham_to_genmat2 @@ -23,9 +23,9 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IRESTART - INTEGER(LONG), INTENT(OUT) :: NELMNT_A - REAL(DOUBLE), INTENT(IN) :: ELSTO + INTEGER, INTENT(IN) :: IRESTART + INTEGER(LONG), INTENT(OUT) :: NELMNT_A + REAL(DOUBLE), INTENT(IN) :: ELSTO !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -43,22 +43,22 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! The following parameters are accumulated in setham which will not ! contain the correct values in restart mode. And thus is skipped. !----------------------------------------------------------------------- - IF (IRESTART /= 0) THEN ! non-restart mode -! WRITE (24, 301) CUTOFFTMP -! WRITE (24, 302) NCOEITMP -! WRITE (24, 303) NCOECTMP -! WRITE (24, 304) NCTEITMP -! WRITE (24, 305) NCTECTMP -! IF (LTRANS) THEN -! WRITE (24, 306) NTPITMP -! WRITE (24, 307) NMCBPTMP -! WRITE (24, 308) NCORETMP -! ENDIF -! IF (LVP) WRITE (24, 309) NVPITMP -! IF (LNMS) WRITE (24, 310) NKEITMP -! IF (LSMS) WRITE (24, 311) NVINTITMP -! ELSE -! WRITE (24, *) 'Restart mode --- no report on radial integrals' + IF (IRESTART /= 0) THEN ! non-restart mode +! WRITE (24, 301) CUTOFFTMP +! WRITE (24, 302) NCOEITMP +! WRITE (24, 303) NCOECTMP +! WRITE (24, 304) NCTEITMP +! WRITE (24, 305) NCTECTMP +! IF (LTRANS) THEN +! WRITE (24, 306) NTPITMP +! WRITE (24, 307) NMCBPTMP +! WRITE (24, 308) NCORETMP +! ENDIF +! IF (LVP) WRITE (24, 309) NVPITMP +! IF (LNMS) WRITE (24, 310) NKEITMP +! IF (LSMS) WRITE (24, 311) NVINTITMP +! ELSE +! WRITE (24, *) 'Restart mode --- no report on radial integrals' CALL MPI_Reduce (NCOEItmp, NCOEI_a, 1, MPI_INTEGER, MPI_SUM, 0, & MPI_COMM_WORLD, ierr) CALL MPI_Reduce (NCOECtmp, NCOEC_a, 1, MPI_INTEGER, MPI_SUM, 0, & @@ -108,10 +108,10 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) IF (myid .EQ. 0) THEN WRITE (24,*) 'Restart mode --- no report on radial integrals' ENDIF - ENDIF !(irestart .NE. 0) ! non-restart mode + ENDIF !(irestart .NE. 0) ! non-restart mode + + - - !----------------------------------------------------------------------- ! ELSTO, EAV are not only for print-out, but also used later. ! density of the Hamiltonian matrix is only for print-out. @@ -119,7 +119,7 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) ! _not_ contain ELSTO. ELSTO will be added to the total energy ! later with EAV. !----------------------------------------------------------------------- - + CALL MPI_Allreduce (NELMNTtmp, NELMNT_a, 1, MPI_INTEGER8, & !AK: MPI_INTEGER8 required to match the sizes of NELMNT_a and NELMNTtmp !CFF & MPI_SUM, MPI_COMM_WORLD, ierr) ! want MAX not SUM @@ -137,25 +137,25 @@ SUBROUTINE GENMAT2(IRESTART, NELMNT_A, ELSTO) WRITE (24,312) NELMNT_a WRITE (24, *) WRITE (24, 300) eav - ENDIF - - 300 FORMAT('Average energy = ',1P,D19.12,' Hartrees.') - 301 FORMAT('CUTOFF set to ',1P,D17.10) - 302 FORMAT('Dirac-Coulomb one-e radial integrals:',1I8) - 303 FORMAT('One-e angular integrals that exceed CUTOFF: ',1I8) - 304 FORMAT('Coulomb two-e radial integrals: ',1I8) - 305 FORMAT('Two-e angular integrals that exceed CUTOFF: ',1I11) - 306 FORMAT('Transverse two-e radial integrals: '/,6I8) + ENDIF + + 300 FORMAT('Average energy = ',1P,D19.12,' Hartrees.') + 301 FORMAT('CUTOFF set to ',1P,D17.10) + 302 FORMAT('Dirac-Coulomb one-e radial integrals:',1I8) + 303 FORMAT('One-e angular integrals that exceed CUTOFF: ',1I8) + 304 FORMAT('Coulomb two-e radial integrals: ',1I8) + 305 FORMAT('Two-e angular integrals that exceed CUTOFF: ',1I11) + 306 FORMAT('Transverse two-e radial integrals: '/,6I8) !cjb 1I8 -> 1I16 ! 307 FORMAT('MCBP coefficients that exceed CUTOFF: ',1I8) - 307 FORMAT('MCBP coefficients that exceed CUTOFF: ',1I16) - 308 FORMAT('Core coefficients that exceed CUTOFF: ',1I8) - 309 FORMAT('Vacuum polarisation integrals: ',1I8) - 310 FORMAT('Kinetic energy integrals: ',1I8) - 311 FORMAT('Vinti integrals: ',1I8) + 307 FORMAT('MCBP coefficients that exceed CUTOFF: ',1I16) + 308 FORMAT('Core coefficients that exceed CUTOFF: ',1I8) + 309 FORMAT('Vacuum polarisation integrals: ',1I8) + 310 FORMAT('Kinetic energy integrals: ',1I8) + 311 FORMAT('Vinti integrals: ',1I8) 312 FORMAT('Elements that exceed CUTOFF in the lower',& - ' triangle of the H matrix: ',1I11) - 313 FORMAT('Density of the H(amiltonian) matrix: ',1P,D22.15) - - RETURN - END SUBROUTINE GENMAT2 + ' triangle of the H matrix: ',1I11) + 313 FORMAT('Density of the H(amiltonian) matrix: ',1P,D22.15) + + RETURN + END SUBROUTINE GENMAT2 diff --git a/src/appl/rci90_mpi/genmat2_I.f90 b/src/appl/rci90_mpi/genmat2_I.f90 index cc7b7f041..e885da22c 100644 --- a/src/appl/rci90_mpi/genmat2_I.f90 +++ b/src/appl/rci90_mpi/genmat2_I.f90 @@ -1,13 +1,13 @@ - MODULE genmat2_I + MODULE genmat2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genmat2 (IRESTART, NELMNT_A, ELSTO) - USE vast_kind_param, ONLY: DOUBLE, LONG - INTEGER, INTENT(IN) :: IRESTART - INTEGER(LONG), INTENT(OUT) :: NELMNT_A - REAL(DOUBLE), INTENT(IN) :: ELSTO - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE genmat2 (IRESTART, NELMNT_A, ELSTO) + USE vast_kind_param, ONLY: DOUBLE, LONG + INTEGER, INTENT(IN) :: IRESTART + INTEGER(LONG), INTENT(OUT) :: NELMNT_A + REAL(DOUBLE), INTENT(IN) :: ELSTO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/genmat_I.f90 b/src/appl/rci90_mpi/genmat_I.f90 index dd40d1d02..85996bbb8 100644 --- a/src/appl/rci90_mpi/genmat_I.f90 +++ b/src/appl/rci90_mpi/genmat_I.f90 @@ -1,17 +1,17 @@ - MODULE genmat_I + MODULE genmat_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE genmat (ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE) :: ATWINV - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - REAL(DOUBLE), INTENT(OUT) :: ELSTO - INTEGER, INTENT(OUT) :: IRESTART + SUBROUTINE genmat (ATWINV, JBLOCK, MYID, NPROCS, ELSTO, IRESTART, SLF_EN) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE) :: ATWINV + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + REAL(DOUBLE), INTENT(OUT) :: ELSTO + INTEGER, INTENT(OUT) :: IRESTART REAL(DOUBLE), DIMENSION(*) :: SLF_EN - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/getcid.f90 b/src/appl/rci90_mpi/getcid.f90 index 9da341068..ede3d3072 100644 --- a/src/appl/rci90_mpi/getcid.f90 +++ b/src/appl/rci90_mpi/getcid.f90 @@ -12,8 +12,8 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! Block version by Xinghong He Last revision: 15 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -98,16 +98,16 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ELSE LFORDR = .FALSE. ENDIF - + ! Get iccutblk() from the user-input - + IF (.NOT. LFORDR) THEN !...Default first DO i = 1, nblock iccutblk(i) = ncfblk(i) ENDDO ELSE - + ! Let master do the i/o, then broadcast IF (myid .EQ. 0) THEN WRITE (istde,*) 'There are ', nblock, 'blocks. They are:' @@ -115,7 +115,7 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) DO i = 1, nblock WRITE (istde,*) i, idblk(i)(1:5), ncfblk(i) ENDDO - + WRITE (istde,*) WRITE (istde,*) 'Enter iccut for each block' DO jblock = 1, nblock @@ -136,16 +136,16 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) CALL MPI_Bcast (iccutblk,nblock,MPI_INTEGER,0, & MPI_COMM_WORLD,ierr) ENDIF ! .NOT. LFORDR - + !***************************************************************** ! ! Pre-run ? ! ! IF (IPRERUN .EQ. 0) THEN - + ! WRITE (istde,*) ' Prerun with limited interaction?' ! YES = GETYN () - + ! IF (YES) THEN ! IPRERUN = 1 ! LTRANS = .FALSE. @@ -153,7 +153,7 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! LNMS = .FALSE. ! LSMS = .FALSE. ! LSE = .FALSE. - + ! WRITE (istde,*) ' Give CSL cut' ! READ *, NCSFPRE ! WRITE (istde,*) ' Give coefficient cut for H_0' @@ -189,13 +189,13 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) IF (myid .EQ. 0) THEN WRITE (istde,*) 'Include H (Vacuum Polarisation)?' LVP = GETYN () - + WRITE (istde,*) 'Include H (Normal Mass Shift)?' LNMS = GETYN () - + WRITE (istde,*) 'Include H (Specific Mass Shift)?' LSMS = GETYN () - + WRITE (istde,*) 'Estimate self-energy?' LSE = GETYN () IF (LSE.EQV..TRUE.) THEN @@ -274,7 +274,7 @@ SUBROUTINE GETCID (isofile, rwffile, idblk) ! WRITE (istde,*) ' revise these values?' ! YES = GETYN () ! ENDIF -! +! ! ...To prevent subsequent BCAST when YES is false ! CALL MPI_Bcast (YES, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) diff --git a/src/appl/rci90_mpi/getcid_I.f90 b/src/appl/rci90_mpi/getcid_I.f90 index aa9b87df7..5b2fc05b9 100644 --- a/src/appl/rci90_mpi/getcid_I.f90 +++ b/src/appl/rci90_mpi/getcid_I.f90 @@ -1,11 +1,11 @@ - MODULE getcid_I + MODULE getcid_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE GETCID (isofile, rwffile, idblk) CHARACTER(LEN=*):: isofile, rwffile CHARACTER(LEN=8), DIMENSION(*) :: idblk - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/hmout.f90 b/src/appl/rci90_mpi/hmout.f90 index ed036b573..56e6777a3 100644 --- a/src/appl/rci90_mpi/hmout.f90 +++ b/src/appl/rci90_mpi/hmout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE HMOUT(IMCDF) + SUBROUTINE HMOUT(IMCDF) ! * ! Routine for printing the Hamiltonian matrix. File IMCDF must be * ! positioned correctly before a call is made to this module. * @@ -10,42 +10,42 @@ SUBROUTINE HMOUT(IMCDF) ! Written by Farid A Parpia Last revision: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE hmat_C USE orb_C, ONLY: ncf, nw, iqa !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IMCDF + INTEGER, INTENT(IN) :: IMCDF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IC, NELC, IR, LENTHR, LENTHC - REAL(DOUBLE) :: ELSTO - CHARACTER :: CIR*8, CIC*8 + INTEGER :: IC, NELC, IR, LENTHR, LENTHC + REAL(DOUBLE) :: ELSTO + CHARACTER :: CIR*8, CIC*8 !----------------------------------------------- ! - DO IC = 1, NCF - READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) - DO IR = 1, NELC - CALL CONVRT (IROW(IR), CIR, LENTHR) - CALL CONVRT (IC, CIC, LENTHC) - WRITE (99, 300) CIR(1:LENTHR), CIC(1:LENTHC), EMT(IR) - END DO - END DO + DO IC = 1, NCF + READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) + DO IR = 1, NELC + CALL CONVRT (IROW(IR), CIR, LENTHR) + CALL CONVRT (IC, CIC, LENTHC) + WRITE (99, 300) CIR(1:LENTHR), CIC(1:LENTHC), EMT(IR) + END DO + END DO ! - 300 FORMAT(' H (',A,',',A,') = ',1P,1D19.12) - RETURN + 300 FORMAT(' H (',A,',',A,') = ',1P,1D19.12) + RETURN ! - END SUBROUTINE HMOUT + END SUBROUTINE HMOUT diff --git a/src/appl/rci90_mpi/hmout_I.f90 b/src/appl/rci90_mpi/hmout_I.f90 index 83f43a6ec..bc8ec631e 100644 --- a/src/appl/rci90_mpi/hmout_I.f90 +++ b/src/appl/rci90_mpi/hmout_I.f90 @@ -1,10 +1,10 @@ - MODULE hmout_I + MODULE hmout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE hmout (IMCDF) - INTEGER, INTENT(IN) :: IMCDF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE hmout (IMCDF) + INTEGER, INTENT(IN) :: IMCDF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/hovlap.f90 b/src/appl/rci90_mpi/hovlap.f90 index 9c86dda0d..6405627e5 100644 --- a/src/appl/rci90_mpi/hovlap.f90 +++ b/src/appl/rci90_mpi/hovlap.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) ! * ! This subprogram computes the overlap of the orbital tabulated in * ! the arrays P and Q with maximum tabulation point MTPO with * @@ -11,13 +11,13 @@ REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C USE horb_C, ONLY: ph, qh @@ -25,37 +25,37 @@ REAL(KIND(0.0D0)) FUNCTION HOVLAP (P, Q, MTPO, NP, KAPPA, Z) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dcbsrw_I - USE quad_I + USE dcbsrw_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPH, I - REAL(DOUBLE) :: EH, PZH, RESULT + INTEGER :: MTPH, I + REAL(DOUBLE) :: EH, PZH, RESULT !----------------------------------------------- ! ! Set up the hydrogenic orbital ! - CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) + CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) ! ! Compute the overlap ! - MTP = MIN(MTPH,MTPO) - TA(1) = 0.0D00 - TA(2:MTP) = (P(2:MTP)*PH(2:MTP)+Q(2:MTP)*QH(2:MTP))*RP(2:MTP) - CALL QUAD (RESULT) + MTP = MIN(MTPH,MTPO) + TA(1) = 0.0D00 + TA(2:MTP) = (P(2:MTP)*PH(2:MTP)+Q(2:MTP)*QH(2:MTP))*RP(2:MTP) + CALL QUAD (RESULT) ! - HOVLAP = RESULT + HOVLAP = RESULT ! - RETURN - END FUNCTION HOVLAP + RETURN + END FUNCTION HOVLAP diff --git a/src/appl/rci90_mpi/hovlap_I.f90 b/src/appl/rci90_mpi/hovlap_I.f90 index 0678c830a..31b981263 100644 --- a/src/appl/rci90_mpi/hovlap_I.f90 +++ b/src/appl/rci90_mpi/hovlap_I.f90 @@ -1,17 +1,17 @@ - MODULE hovlap_I + MODULE hovlap_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION hovlap (P, Q, MTPO, NP, KAPPA, Z) - USE vast_kind_param, ONLY: DOUBLE + REAL(KIND(0.0D0)) FUNCTION hovlap (P, Q, MTPO, NP, KAPPA, Z) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/iabint.f90 b/src/appl/rci90_mpi/iabint.f90 index eb8dbd27c..00f4e826c 100644 --- a/src/appl/rci90_mpi/iabint.f90 +++ b/src/appl/rci90_mpi/iabint.f90 @@ -13,8 +13,8 @@ SUBROUTINE IABINT (IA,IB,TEGRAL) ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/iabint_I.f90 b/src/appl/rci90_mpi/iabint_I.f90 index 12928c301..f7da36582 100644 --- a/src/appl/rci90_mpi/iabint_I.f90 +++ b/src/appl/rci90_mpi/iabint_I.f90 @@ -1,12 +1,12 @@ - MODULE iabint_I + MODULE iabint_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE IABINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER, INTENT(INOUT) :: ia, ib REAL(DOUBLE), INTENT(out) :: tegral - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/indtpi.f90 b/src/appl/rci90_mpi/indtpi.f90 index c38584b7f..d83771cad 100644 --- a/src/appl/rci90_mpi/indtpi.f90 +++ b/src/appl/rci90_mpi/indtpi.f90 @@ -1,12 +1,12 @@ !*********************************************************************** ! * - INTEGER FUNCTION INDTPI (ITYPE, I) + INTEGER FUNCTION INDTPI (ITYPE, I) ! * ! Written by Farid A Parpia Last revision: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 USE bilst_C !----------------------------------------------- @@ -16,24 +16,24 @@ INTEGER FUNCTION INDTPI (ITYPE, I) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: I + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: I !----------------------------------------------- ! - SELECT CASE (ITYPE) - CASE (1) - INDTPI = INDTP1(I) - CASE (2) - INDTPI = INDTP2(I) - CASE (3) - INDTPI = INDTP3(I) - CASE (4) - INDTPI = INDTP4(I) - CASE (5) - INDTPI = INDTP5(I) - CASE (6) - INDTPI = INDTP6(I) - END SELECT + SELECT CASE (ITYPE) + CASE (1) + INDTPI = INDTP1(I) + CASE (2) + INDTPI = INDTP2(I) + CASE (3) + INDTPI = INDTP3(I) + CASE (4) + INDTPI = INDTP4(I) + CASE (5) + INDTPI = INDTP5(I) + CASE (6) + INDTPI = INDTP6(I) + END SELECT ! - RETURN - END FUNCTION INDTPI + RETURN + END FUNCTION INDTPI diff --git a/src/appl/rci90_mpi/indtpi_I.f90 b/src/appl/rci90_mpi/indtpi_I.f90 index c25481ad3..e21225c73 100644 --- a/src/appl/rci90_mpi/indtpi_I.f90 +++ b/src/appl/rci90_mpi/indtpi_I.f90 @@ -1,11 +1,11 @@ - MODULE indtpi_I + MODULE indtpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION indtpi (ITYPE, I) - INTEGER, INTENT(IN) :: ITYPE - INTEGER :: I - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION indtpi (ITYPE, I) + INTEGER, INTENT(IN) :: ITYPE + INTEGER :: I + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/iniestdm.f90 b/src/appl/rci90_mpi/iniestdm.f90 index 572983636..9eb465ccc 100644 --- a/src/appl/rci90_mpi/iniestdm.f90 +++ b/src/appl/rci90_mpi/iniestdm.f90 @@ -1,7 +1,7 @@ !************************************************************************ ! SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) - + ! Routine for providing initial estimates from the diagonal ! of the matrix. This way was used by Dvdson in atomic structure ! calculations. It should be used to obtain estimates when nothing @@ -10,8 +10,8 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) ! Block version by Xinghong He Last revision: 18 Jun 1998 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -40,10 +40,10 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) REAL :: SLAMCH !----------------------------------------------------------------------- NS = MIN (nmax, ncf) - + CALL alloc (ap, NS*(NS+1)/2, 'AP', 'INIESTDM') CALL dinit (NS*(NS+1)/2, 0.d0, ap, 1) - + ! Get the upper left sub-matrix ! ap is global, hmx is local !!! @@ -54,14 +54,14 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) ap(j+iap) = hmx(j+ihmx) ENDDO ihmx = ihmx + i - ENDDO - + ENDDO + CALL alloc (eigval, NS, 'EIGVAL', 'INIESTDM') CALL alloc (vec, NS*NIV, 'VEC', 'INIESTDM') CALL alloc (work, 8*NS, 'WORK', 'INIESTDM') CALL alloc (iwork, 5*NS, 'IWORK', 'INIESTDM') CALL alloc (ifail, NS, 'IFAIL', 'INIESTDM') - + ! CALL DSPEVX ('Vectors also','In a range','Upper triangular', & ! & NS,AP,-1.0D0,-1.0D0,1,NIV,0.d0, & ! & NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) @@ -70,25 +70,25 @@ SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) NS,AP,-1.d0,-1.d0,1,NIV,ABSTOL, & NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) IERR = -ABS (INFO) - + ! Build the Basis. - + CALL DINIT (ncf*NIV, 0.D0, BASIS, 1) - + ! scatter the vectors - + DO J = 1, NIV CALL dcopy (ns, vec(ns*(j-1)+1),1, basis(ncf*(j-1)+1), 1) ENDDO - + CALL dcopy (NIV, EIGVAL, 1, BASIS(NIV*ncf+1), 1) - + CALL dalloc (ap, 'AP', 'INIESTDM') CALL dalloc (eigval, 'EIGVAL', 'INIESTDM') CALL dalloc (vec, 'VEC', 'INIESTDM') CALL dalloc (work, 'WORK', 'INIESTDM') CALL dalloc (iwork, 'IWORK', 'INIESTDM') CALL dalloc (ifail, 'IFAIL', 'INIESTDM') - + RETURN END diff --git a/src/appl/rci90_mpi/iniestdm_I.f90 b/src/appl/rci90_mpi/iniestdm_I.f90 index 57ad5401c..97a146f4f 100644 --- a/src/appl/rci90_mpi/iniestdm_I.f90 +++ b/src/appl/rci90_mpi/iniestdm_I.f90 @@ -1,12 +1,12 @@ - MODULE iniestdm_I + MODULE iniestdm_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE INIESTdm (nmax, ncf, NIV, BASIS, hmx) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN):: nmax, ncf, niv REAL(DOUBLE), DIMENSION(*) :: basis, hmx END SUBROUTINE INIESTDM - END INTERFACE - END MODULE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/iniestsd.f90 b/src/appl/rci90_mpi/iniestsd.f90 index 1314b3071..fd0823415 100644 --- a/src/appl/rci90_mpi/iniestsd.f90 +++ b/src/appl/rci90_mpi/iniestsd.f90 @@ -12,8 +12,8 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ! Block version by Xinghong He Last revision: 14 Dec 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -42,13 +42,13 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & REAL :: SLAMCH !----------------------------------------------------------------------- NS = min (nmax, ncf) - + CALL alloc (ap, (NS*(NS+1))/2, 'AP', 'INIESTSD') !GG CALL alloc (ap_buffer, (NS*(NS+1))/2, 'AP', 'INIESTSD') CALL dinit ((NS*(NS+1))/2, 0.d0, ap, 1) - + !**** separate upper left block of size NS*NS - + CALL alloc (hmx, ncf, 'HMX', 'INIESTSD') CALL alloc (irow, ncf, 'IROW', 'INIESTSD') READ (imcdf) ncfdum, iccutdum, myiddum, nprocsdum @@ -56,10 +56,10 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & IF (ncf .NE. ncfdum .OR. myid .NE. myiddum & .OR. nprocsdum .NE. nprocs) & STOP 'iniestsd: ncf read wrong' - + ! if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; ! if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. - + DO j = myid + 1, ns, nprocs joff = (j*(j-1))/2 READ (IMCDF) NELC,ELSTO,(HMX(IR),IR=1,NELC), & @@ -69,11 +69,11 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ap(irow(ir) + joff) = hmx(ir) ENDDO ENDDO - + ! Let each node have a complete copy of ap - + CALL gdsummpi (ap, (NS*(NS+1))/2) - + ! To be in step with other cases, go through the whole block. ! ! This is not necessary since currently the file pointer is moved @@ -81,21 +81,21 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & ! from the begining of the .res files of each node. Besides, the ! following segment seems not working properly for the last block. ! Xinghong He 98-12-14 - + !mylast = j - nprocs !DO j = mylast, ncf, nprocs ! READ (imcdf) !ENDDO - + CALL dalloc (hmx,'HMX', 'INIESTSD') CALL dalloc (irow, 'HMX', 'INIESTSD') - + CALL alloc (eigval,NS,'EIGVAL','INIESTSD') CALL alloc (vec,NS*NIV,'VEC','INIESTSD') CALL alloc (work,8*NS,'WORK','INIESTSD') CALL alloc (iwork,5*NS,'IWORK','INIESTSD' ) CALL alloc (ifail,NS, 'IFAIL','INIESTSD' ) - + ! CALL DSPEVX ('Vectors also','In a range','Upper triangular', & ! NS,AP,-1.0D0,-1.0D0,1,NIV,0.d0, & ! NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) @@ -104,24 +104,24 @@ SUBROUTINE INIESTSD (nmax, ncf, myid, nprocs, & NS,AP,-1.d0,-1.d0,1,NIV,ABSTOL, & NFOUND,EIGVAL,VEC,NS,work,iwork,IFAIL,INFO) IERR = -ABS (INFO) - + !****************************************************************** - + ! ..Build the Basis. - + CALL DINIT (ncf*NIV, 0.D0, BASIS, 1) ! ...scatter the vectors DO J = 1, NIV CALL dcopy (ns, vec(ns*(j-1)+1),1, basis(ncf*(j-1)+1), 1) ENDDO CALL dcopy (NIV, EIGVAL,1,BASIS(NIV*ncf+1),1) - + CALL dalloc (ap, 'AP', 'INIESTSD') CALL dalloc (eigval,'EIGVAL', 'INIESTSD') CALL dalloc (vec, 'VEC', 'INIESTSD') CALL dalloc (work, 'WORK', 'INIESTSD') CALL dalloc (iwork, 'IWORK', 'INIESTSD') CALL dalloc (ifail, 'IFAIL', 'INIESTSD') - + RETURN END SUBROUTINE INIESTSD diff --git a/src/appl/rci90_mpi/iniestsd_I.f90 b/src/appl/rci90_mpi/iniestsd_I.f90 index 2626e894d..305592cab 100644 --- a/src/appl/rci90_mpi/iniestsd_I.f90 +++ b/src/appl/rci90_mpi/iniestsd_I.f90 @@ -1,13 +1,13 @@ - MODULE iniestsd_I + MODULE iniestsd_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE INIESTSD (nmax,ncf, myid,nprocs,NIV,BASIS,IMCDF,EAV) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: nmax, ncf, myid, nprocs, niv, imcdf REAL(DOUBLE), INTENT(IN) :: EAV REAL(DOUBLE), DIMENSION(*), INTENT(IN):: Basis - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/keint.f90 b/src/appl/rci90_mpi/keint.f90 index 8b1eb65a9..845120f89 100644 --- a/src/appl/rci90_mpi/keint.f90 +++ b/src/appl/rci90_mpi/keint.f90 @@ -13,8 +13,8 @@ SUBROUTINE KEINT (IA,IB,TEGRAL) ! Written by Farid A Parpia Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -22,7 +22,7 @@ SUBROUTINE KEINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man - USE keilst_C + USE keilst_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- diff --git a/src/appl/rci90_mpi/keint_I.f90 b/src/appl/rci90_mpi/keint_I.f90 index 14fbaf8ef..5dae76039 100644 --- a/src/appl/rci90_mpi/keint_I.f90 +++ b/src/appl/rci90_mpi/keint_I.f90 @@ -1,12 +1,12 @@ - MODULE keint_I + MODULE keint_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE KEINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER, INTENT(INOUT) :: ia, ib REAL(DOUBLE), INTENT(out) :: tegral - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/klamaq.f90 b/src/appl/rci90_mpi/klamaq.f90 index 2bc8244c1..b5107ead7 100644 --- a/src/appl/rci90_mpi/klamaq.f90 +++ b/src/appl/rci90_mpi/klamaq.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) + SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) ! * ! The function F (Z*\alpha) is estimated here. We use the series * ! expansion given by Eqs (1) and (2) and the table of Bethe loga- * @@ -10,29 +10,29 @@ SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(IN) :: KAPPA - REAL(DOUBLE) , INTENT(IN) :: Z - REAL(DOUBLE) , INTENT(OUT) :: FZALFA + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(IN) :: KAPPA + REAL(DOUBLE) , INTENT(IN) :: Z + REAL(DOUBLE) , INTENT(OUT) :: FZALFA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L, LOC - REAL(DOUBLE), DIMENSION(36) :: BETHE - REAL(DOUBLE) :: C401, C402, OVLFAC, BETHEL, TERM, ZALFA, FACTOR - LOGICAL :: FIRST + INTEGER :: L, LOC + REAL(DOUBLE), DIMENSION(36) :: BETHE + REAL(DOUBLE) :: C401, C402, OVLFAC, BETHEL, TERM, ZALFA, FACTOR + LOGICAL :: FIRST !----------------------------------------------- ! DATA BETHE/ 2.9841285D00, 2.8117699D00, -0.0300167D00, 2.7676636D00, & @@ -43,87 +43,87 @@ SUBROUTINE KLAMAQ(N, KAPPA, Z, FZALFA) -0.0004079D00, 2.7324291D00, -0.0461552D00, -0.0085192D00, & -0.0027091D00, -0.0010945D00, -0.0004997D00, -0.0002409D00, & 2.7302673D00, -0.0467413D00, -0.0087850D00, -0.0028591D00, & - -0.0011904D00, -0.0005665D00, -0.0002904D00, -0.0001539D00/ + -0.0011904D00, -0.0005665D00, -0.0002904D00, -0.0001539D00/ ! !----------------------------------------------------------------------* ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! - DATA C401/ 0.0D00/ - DATA C402/ 0.0D00/ - DATA OVLFAC/ 0.0D00/ + DATA C401/ 0.0D00/ + DATA C402/ 0.0D00/ + DATA OVLFAC/ 0.0D00/ ! ! Set up the constants ! - IF (FIRST) THEN + IF (FIRST) THEN ! - C401 = 11.0D00/24.0D00 - C402 = 3.0D00/8.0D00 - OVLFAC = 4.0D00/3.0D00 + C401 = 11.0D00/24.0D00 + C402 = 3.0D00/8.0D00 + OVLFAC = 4.0D00/3.0D00 ! - FIRST = .FALSE. + FIRST = .FALSE. ! - ENDIF + ENDIF ! ! Ensure that the principal quantum number is in range ! - IF (N<1 .OR. N>8) THEN - WRITE (*, 300) - WRITE (*, 301) N - STOP - ENDIF + IF (N<1 .OR. N>8) THEN + WRITE (*, 300) + WRITE (*, 301) N + STOP + ENDIF ! ! Determine the azimuthal quantum number ! - IF (KAPPA > 0) THEN - L = KAPPA - ELSE IF (KAPPA == 0) THEN - WRITE (*, 300) - WRITE (*, 302) - STOP - ELSE - L = (-KAPPA) - 1 - ENDIF + IF (KAPPA > 0) THEN + L = KAPPA + ELSE IF (KAPPA == 0) THEN + WRITE (*, 300) + WRITE (*, 302) + STOP + ELSE + L = (-KAPPA) - 1 + ENDIF ! ! Ensure that the azimuthal quantum number is in range ! - IF (L > N - 1) THEN - WRITE (*, 300) - WRITE (*, 303) KAPPA, N - STOP - ENDIF + IF (L > N - 1) THEN + WRITE (*, 300) + WRITE (*, 303) KAPPA, N + STOP + ENDIF ! ! Find the appropriate entry in the table ! - LOC = (N*N - N)/2 + L + 1 - BETHEL = BETHE(LOC) + LOC = (N*N - N)/2 + L + 1 + BETHEL = BETHE(LOC) ! ! Determine the quantity in square brackets in eq. (1) of ! Klarsfeld and Maquet ! - TERM = -BETHEL + TERM = -BETHEL ! - IF (KAPPA > 0) THEN - TERM = TERM - C402/DBLE(L*(L + L + 1)) - ELSE - TERM = TERM + C402/DBLE((L + 1)*(L + L + 1)) - IF (KAPPA == (-1)) THEN - ZALFA = Z/C - FACTOR = DLOG(ZALFA) - FACTOR = -(FACTOR + FACTOR) - TERM = TERM + FACTOR + C401 - ENDIF - ENDIF + IF (KAPPA > 0) THEN + TERM = TERM - C402/DBLE(L*(L + L + 1)) + ELSE + TERM = TERM + C402/DBLE((L + 1)*(L + L + 1)) + IF (KAPPA == (-1)) THEN + ZALFA = Z/C + FACTOR = DLOG(ZALFA) + FACTOR = -(FACTOR + FACTOR) + TERM = TERM + FACTOR + C401 + ENDIF + ENDIF ! - FZALFA = OVLFAC*TERM + FZALFA = OVLFAC*TERM ! - RETURN + RETURN ! - 300 FORMAT('KLAMAQ:') + 300 FORMAT('KLAMAQ:') 301 FORMAT(' Principal quantum number, ',1I2,& - ', should be in the range 1--8.') - 302 FORMAT(' Kappa is 0 .') - 303 FORMAT(' Kappa, ',1I3,', is out of range for n, ',1I2,'.') - RETURN + ', should be in the range 1--8.') + 302 FORMAT(' Kappa is 0 .') + 303 FORMAT(' Kappa, ',1I3,', is out of range for n, ',1I2,'.') + RETURN ! - END SUBROUTINE KLAMAQ + END SUBROUTINE KLAMAQ diff --git a/src/appl/rci90_mpi/klamaq_I.f90 b/src/appl/rci90_mpi/klamaq_I.f90 index 83126a8dc..e0ad19cb6 100644 --- a/src/appl/rci90_mpi/klamaq_I.f90 +++ b/src/appl/rci90_mpi/klamaq_I.f90 @@ -1,14 +1,14 @@ - MODULE klamaq_I + MODULE klamaq_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE klamaq (N, KAPPA, Z, FZALFA) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE), INTENT(IN) :: Z - REAL(DOUBLE), INTENT(OUT) :: FZALFA - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE klamaq (N, KAPPA, Z, FZALFA) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE), INTENT(IN) :: Z + REAL(DOUBLE), INTENT(OUT) :: FZALFA + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/lodmixmpi.f90 b/src/appl/rci90_mpi/lodmixmpi.f90 index 3a45ec386..74dbba6b9 100644 --- a/src/appl/rci90_mpi/lodmixmpi.f90 +++ b/src/appl/rci90_mpi/lodmixmpi.f90 @@ -11,8 +11,8 @@ SUBROUTINE LODMIXmpi (idblk) ! Block version by Xinghong He Last revision: 9 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -39,15 +39,15 @@ SUBROUTINE LODMIXmpi (idblk) INTEGER :: ncftot, noffset, nvecsiz, jb, j INTEGER :: NELEC4, ncftot4, NW4, ncmin4, nvecsiz4, nblock4 !----------------------------------------------- - + ! lodstate generates ! nevblk(), ncmaxblk() ! ncmin, iccmin(1:ncmin) -- via items (memories allocated there) ! Thus we let node-0 do it and then broadcast here - + CALL alloc (ncmaxblk, nblock, 'NCMAXBLK', 'LODMIXmpi') CALL alloc (nevblk, nblock, 'NEVBLK', 'LODMIXmpi') - + ! print *, ' LODMIX: change lodstate arg-list - see rscf2/getold.f90 ' ! stop IF (myid .EQ. 0) THEN diff --git a/src/appl/rci90_mpi/lodmixmpi_I.f90 b/src/appl/rci90_mpi/lodmixmpi_I.f90 index cdcf36594..6e77658cf 100644 --- a/src/appl/rci90_mpi/lodmixmpi_I.f90 +++ b/src/appl/rci90_mpi/lodmixmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE lodmixmpi_I + MODULE lodmixmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LODMIXmpi (idblk) CHARACTER(LEN=8),DIMENSION(*), INTENT(IN):: idblk - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/lodres.f90 b/src/appl/rci90_mpi/lodres.f90 index 71ac15b06..865605c1b 100644 --- a/src/appl/rci90_mpi/lodres.f90 +++ b/src/appl/rci90_mpi/lodres.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRES + SUBROUTINE LODRES ! * ! Loads the data from the .res file. A number of checks are made * ! to ensure correctness and consistency. * @@ -15,13 +15,13 @@ SUBROUTINE LODRES ! Block version by Xinghong He Last revision: 1 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE memory_man USE decide_C @@ -40,14 +40,14 @@ SUBROUTINE LODRES !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setqic_I + USE getyn_I + USE setqic_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCFRES, NWRES, NBLOCKRES, I, NP10, J - LOGICAL :: YES + INTEGER :: NCFRES, NWRES, NBLOCKRES, I, NP10, J + LOGICAL :: YES !----------------------------------------------- ! ! POINTER (pncfblk, ncfblk(0:*)) @@ -59,63 +59,63 @@ SUBROUTINE LODRES ! Read the basic parameters of the electron cloud; check these ! against those deduced from the .csl file ! - READ (IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES - + READ (IMCDF) NELECR, NCFRES, NWRES, NBLOCKRES + IF (NELECR/=NELEC .OR. NCFRES/=NCF .OR. NWRES/=NW .OR. NBLOCKRES/=NBLOCK& ) CALL STOPMPI ('lodres: NELEC/NCF/NW does not match',myid) ! ! Read the nuclear parameters ! - READ (IMCDF) Z, EMN - READ (IMCDF) NPARM, (PARM(I),I=1,NPARM) - READ (IMCDF) N, (ZZ(I),I=1,N), NNUC - + READ (IMCDF) Z, EMN + READ (IMCDF) NPARM, (PARM(I),I=1,NPARM) + READ (IMCDF) N, (ZZ(I),I=1,N), NNUC + IF (N > NNNP) CALL STOPMPI ('lodres: N greater than NNNP',myid) ! ! Read the physical effects specifications ! iccutblk() is now an array of length nblock. ! READ (IMCDF) C, LFORDR, (ICCUTBLK(I),I=1,NBLOCK), LTRANS, WFACT, LVP, & - LNMS, LSMS + LNMS, LSMS ! ! Read the remaining parameters controlling the radial grid and the ! grid arrays ! - NP10 = N + 10 + NP10 = N + 10 READ (IMCDF) RNT, H, HP, (R(I),I=1,NP10), (RP(I),I=1,NP10), (RPOR(I),I=1,& - NP10) + NP10) ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Allocate storage for the radial wavefunction arrays ! - CALL ALLOC (PF, NNNP,NW, 'PF', 'LODMIX') - CALL ALLOC (QF, NNNP,NW, 'QF', 'LODMIX') + CALL ALLOC (PF, NNNP,NW, 'PF', 'LODMIX') + CALL ALLOC (QF, NNNP,NW, 'QF', 'LODMIX') ! ! Read the orbital wavefunctions and the associated arrays ! - DO J = 1, NW - READ (IMCDF) E(J), GAMA(J), PZ(J), MF(J) - READ (IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) - END DO + DO J = 1, NW + READ (IMCDF) E(J), GAMA(J), PZ(J), MF(J) + READ (IMCDF) (PF(I,J),I=1,MF(J)), (QF(I,J),I=1,MF(J)) + END DO ! ! Determine if the self-energy contribution is to be estimated ! IF (MYID == 0) THEN WRITE (ISTDE, *) 'Estimate contributions from the self-energy?' - LSE = GETYN() + LSE = GETYN() IF (LSE) THEN WRITE(734,'(a)') 'y ! Estimate contributions from the self-energy?' ELSE WRITE(734,'(a)') 'n ! Estimate contributions from the self-energy?' END IF ENDIF - CALL MPI_BCAST (LSE, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, IERR) - RETURN - END SUBROUTINE LODRES + CALL MPI_BCAST (LSE, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, IERR) + RETURN + END SUBROUTINE LODRES diff --git a/src/appl/rci90_mpi/lodres_I.f90 b/src/appl/rci90_mpi/lodres_I.f90 index e56f23421..b7e055c59 100644 --- a/src/appl/rci90_mpi/lodres_I.f90 +++ b/src/appl/rci90_mpi/lodres_I.f90 @@ -1,9 +1,9 @@ - MODULE lodres_I + MODULE lodres_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodres - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodres + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/maneigmpi.f90 b/src/appl/rci90_mpi/maneigmpi.f90 index c66f24af9..d313efc92 100644 --- a/src/appl/rci90_mpi/maneigmpi.f90 +++ b/src/appl/rci90_mpi/maneigmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) + SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! * ! This module manages the operation of the eigensolvers and the * ! storage of the eigenpairs. There are two principal branches: * @@ -31,7 +31,7 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! nodes * ! * ! value meaning of method used IV * -! 1 LAPACK => ncf < IOLPCK * +! 1 LAPACK => ncf < IOLPCK * ! 2 Davidson, Dense-Memory => dense requires less memory * ! 3 Davidson, Sparse-Memory => sparse requires less memory * ! 4 Davidson, Sparse-Disk => memory requirement too large * @@ -55,11 +55,11 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! Block Version By Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE, LONG USE memory_man @@ -69,24 +69,24 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) USE orb_C, ONLY: ncf, nw, iqa USE prnt_C USE where_C - USE WCHBLK_C + USE WCHBLK_C USE iounit_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dnicmv_I - USE spicmv2_I - USE spodmv_I - USE posfile_I - USE dinit_I - USE dspevx_I - USE iniestsd_I - USE gdvd_I - USE iniest2_I - USE iniestdm_I - USE itjpo_I - USE ispar_I + USE dnicmv_I + USE spicmv2_I + USE spodmv_I + USE posfile_I + USE dinit_I + USE dspevx_I + USE iniestsd_I + USE gdvd_I + USE iniest2_I + USE iniestdm_I + USE itjpo_I + USE ispar_I USE spicmvmpi_I IMPLICIT NONE !----------------------------------------------- @@ -97,14 +97,14 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: IATJPO - INTEGER, INTENT(OUT) :: IASPAR + INTEGER, INTENT(OUT) :: IATJPO + INTEGER, INTENT(OUT) :: IASPAR INTEGER(LONG) :: NELMNT_a !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: IOLPCK = 2000 -! GG REAL(DOUBLE), PARAMETER :: ABSTOL = 1.0D-10 + INTEGER, PARAMETER :: IOLPCK = 2000 +! GG REAL(DOUBLE), PARAMETER :: ABSTOL = 1.0D-10 !cjb NINCOR !cjb INTEGER, PARAMETER :: NINCOR = 1 ! To enforce DISK INTEGER, PARAMETER :: NINCOR = 268435456 ! = 2 GB or memory @@ -112,7 +112,7 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! L o c a l V a r i a b l e s !----------------------------------------------- !cff ... variable for deciding between sparse or dense -! Memory need: +! Memory need: ! sparse : nstore_s = nelmnt + (isize*(nelmnt + ncf+1))/8 ! dense : nstore_d = (ncf*ncf+1))/(2*nprocs) (on average) ! Use Davidson (disk) if nstore_s > NINCOR @@ -127,104 +127,104 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) idummy REAL(DOUBLE) :: ELSTO, DUMMY, & DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA, ABSTOL -! GG DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA - LOGICAL :: HIEND, LDISC, SPARSE - CHARACTER(LEN=8) :: CNUM +! GG DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA + LOGICAL :: HIEND, LDISC, SPARSE + CHARACTER(LEN=8) :: CNUM REAL(DOUBLE), DIMENSION(:), pointer :: w, z, work, diag INTEGER, DIMENSION(:), pointer :: iwork, ifail, jwork !----------------------------------------------- ! !----------------------------------------------------------------------- ABSTOL = 2*DLAMCH('S') - IF (MYID == 0) WRITE (6, *) 'Calling maneig...' - + IF (MYID == 0) WRITE (6, *) 'Calling maneig...' + ! (nrows+1) is the number of records of the present block's .res file - - NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS - IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) + + NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS + IF (NCF < NPROCS) NROWS = NCF/(MYID + 1) !CALL posfile (1, imcdf, nrows+1) - CALL POSFILE (0, IMCDF, NPOSITION) - - IF (NCF == 1) THEN + CALL POSFILE (0, IMCDF, NPOSITION) + + IF (NCF == 1) THEN !----------------------------------------------------------------------- ! ! (1) - Trivial ncf = 1 ! !------------------------------------------------------- - IF (myid .EQ. 0) WRITE (24, *) 'Trivial eigenvalue problem.' - + IF (myid .EQ. 0) WRITE (24, *) 'Trivial eigenvalue problem.' + ! Matrix of order 1: the trivial case; we assume that the value ! of EAV is available - - CALL ALLOC (EVAL, 1,'EVAL', 'MANEIG' ) - CALL ALLOC (EVEC, 1, 'EVECO', 'MANEIG') - EVAL(1) = 0.D0 - EVEC(1) = 1.D0 - + + CALL ALLOC (EVAL, 1,'EVAL', 'MANEIG' ) + CALL ALLOC (EVEC, 1, 'EVECO', 'MANEIG') + EVAL(1) = 0.D0 + EVEC(1) = 1.D0 + ! Still read through the .res file !GG !GG Gediminas NIST 2005.11.03 !GG READ (imcdf) - DO I = 1, NROWS + 1 - READ (IMCDF) - END DO - - ELSE !if-2 -!----------------------------------------------------------------------- + DO I = 1, NROWS + 1 + READ (IMCDF) + END DO + + ELSE !if-2 +!----------------------------------------------------------------------- ! ! (2) - Non trivial ! !------------------------------------------------------- if(myid==0) write(*,*) "ncf=",ncf, " iolpck=", iolpck - IF (NCF <= IOLPCK) THEN -!----------------------------------------------------------------------- + IF (NCF <= IOLPCK) THEN +!----------------------------------------------------------------------- ! ! (2.1) - LAPACK Dense, Memory, ! !------------------------------------------------------- - IF (MYID == 0) THEN + IF (MYID == 0) THEN WRITE (6, *) & - 'LAPACK routine DSPEVX selected for eigenvalue problem.' + 'LAPACK routine DSPEVX selected for eigenvalue problem.' WRITE (24, *) & - 'LAPACK routine DSPEVX selected for eigenvalue problem.' - ENDIF - + 'LAPACK routine DSPEVX selected for eigenvalue problem.' + ENDIF + ! Allocate storage for the dense representation of the matrix ! and initialize emt - - NDENSE = (NCF*(NCF + 1))/2 - CALL ALLOC (EMT, NDENSE, 'EMT', 'MANEIG') - CALL DINIT (NDENSE, 0.0D00, EMT, 1) - -! Read the matrix into position from the disc file; it's already + + NDENSE = (NCF*(NCF + 1))/2 + CALL ALLOC (EMT, NDENSE, 'EMT', 'MANEIG') + CALL DINIT (NDENSE, 0.0D00, EMT, 1) + +! Read the matrix into position from the disc file; it's already ! been properly positioned. - - CALL ALLOC (WORK, NCF,'WORK', 'MANEIG' ) - CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + CALL ALLOC (WORK, NCF,'WORK', 'MANEIG' ) + CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'maneig:1' - - DO I = MYID + 1, NCF, NPROCS - IOFSET = (I*(I - 1))/2 + 'maneig:1' + + DO I = MYID + 1, NCF, NPROCS + IOFSET = (I*(I - 1))/2 READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),IR=1,& - NELC) + NELC) ! In the row-mode of the lower triangle, ! diagonal is the last one - DO IR = 1, NELC - 1 - EMT(IOFSET+IROW(IR)) = WORK(IR) - END DO - EMT(IOFSET+IROW(NELC)) = WORK(NELC) - EAV - - END DO - - CALL DALLOC (WORK, 'WORK', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') + DO IR = 1, NELC - 1 + EMT(IOFSET+IROW(IR)) = WORK(IR) + END DO + EMT(IOFSET+IROW(NELC)) = WORK(NELC) - EAV + + END DO + + CALL DALLOC (WORK, 'WORK', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') ! Let each node have a complete copy of EMT CALL gdsummpi (EMT, NDENSE) - + ! Find the eigenpairs ! ! ivec() - serial numbers of eigenstates of the current block @@ -232,50 +232,50 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! nvecmn - minimum serial number of the eigenstates of the block ! nvecmx - maximum ............. ! nvex - clear from def: NVECMX-NVECMN+1 - - NVECMN = NCF - DO I = 1, NVEC - NVECMN = MIN(NVECMN,IVEC(I)) - END DO - NVEX = NVECMX - NVECMN + 1 - CALL ALLOC (W, NVEX, 'W', 'MANEIG') - CALL ALLOC (Z, NCF*NVEX,'Z', 'MANEIG' ) - CALL ALLOC (WORK, NCF*8,'WORK', 'MANEIG' ) - CALL ALLOC (IWORK, NCF*5,'IWORK', 'MANEIG' ) -! GG CALL ALLOC (IFAIL, NVEX, 'IFAIL', 'MANEIG') - CALL ALLOC (IFAIL, NCF, 'IFAIL', 'MANEIG') + + NVECMN = NCF + DO I = 1, NVEC + NVECMN = MIN(NVECMN,IVEC(I)) + END DO + NVEX = NVECMX - NVECMN + 1 + CALL ALLOC (W, NVEX, 'W', 'MANEIG') + CALL ALLOC (Z, NCF*NVEX,'Z', 'MANEIG' ) + CALL ALLOC (WORK, NCF*8,'WORK', 'MANEIG' ) + CALL ALLOC (IWORK, NCF*5,'IWORK', 'MANEIG' ) +! GG CALL ALLOC (IFAIL, NVEX, 'IFAIL', 'MANEIG') + CALL ALLOC (IFAIL, NCF, 'IFAIL', 'MANEIG') CALL DSPEVX ('V', 'I', 'U', NCF, EMT, DUMMY, DUMMY, NVECMN, NVECMX& - , ABSTOL, M, W, Z, NCF, WORK, IWORK, IFAIL, INFO) + , ABSTOL, M, W, Z, NCF, WORK, IWORK, IFAIL, INFO) IF (INFO /= 0) & - CALL STOPMPI('maneig: Failure in DSPEVX [LAPACK]',myid) - CALL DALLOC (WORK, 'WORK', 'MANEIG') + CALL STOPMPI('maneig: Failure in DSPEVX [LAPACK]',myid) + CALL DALLOC (WORK, 'WORK', 'MANEIG') CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL DALLOC (IFAIL, 'IFAIL', 'MANEIG') - CALL DALLOC (EMT, 'EMT', 'MANEIG') - + CALL DALLOC (IFAIL, 'IFAIL', 'MANEIG') + CALL DALLOC (EMT, 'EMT', 'MANEIG') + ! Store the eigenpairs in their proper positions EVAL() and EVEC() - CALL ALLOC (EVAL, NVEC,'EVAL', 'MANEIG') + CALL ALLOC (EVAL, NVEC,'EVAL', 'MANEIG') CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG') - DO I = 1, NVEC - LOC = IVEC(I) - EVAL(I) = W(LOC - NVECMN + 1) - IOFSET = NCF*(I - 1) - LOC = NCF*(LOC - NVECMN) - CALL DCOPY (NCF, Z(LOC + 1), 1, EVEC(IOFSET+1), 1) - END DO - CALL DALLOC (W, 'W', 'MANEIG') - CALL DALLOC (Z, 'Z', 'MANEIG') - - ELSE + DO I = 1, NVEC + LOC = IVEC(I) + EVAL(I) = W(LOC - NVECMN + 1) + IOFSET = NCF*(I - 1) + LOC = NCF*(LOC - NVECMN) + CALL DCOPY (NCF, Z(LOC + 1), 1, EVEC(IOFSET+1), 1) + END DO + CALL DALLOC (W, 'W', 'MANEIG') + CALL DALLOC (Z, 'Z', 'MANEIG') + + ELSE !----------------------------------------------------------------------- - + ! (2.2) - DVDSON --- preparation work ! !------------------------------------------------------- IF (myid == 0) WRITE (24,*)'DVDSON routine selected' & - //' for eigenvalue problem;' + //' for eigenvalue problem;' !-------------------------------------------------------------- IF (myid == 0) print *,'zou: nelmnt',NELMNT ! print *, 'myid, nprocs,nincor', myid, nprocs, nincor @@ -286,9 +286,9 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! dense storage = (ncf*(ncf+1)/2/nproc - on average ! (because of integer arithmetic nproc-1 is added to numerator -! This is a comparion of matrix elements only. +! This is a comparion of matrix elements only. ! - NSTORE_s = NELMNT_a + NSTORE_s = NELMNT_a NSTORE_d = ((ncf+nprocs-1)/nprocs) NSTORE_d = NSTORE_d*((ncf+1)/2) IF (myid .EQ. 0) write(*,*) "nstore_s=", nstore_s, & @@ -309,37 +309,37 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) CALL ALLOC (DIAG,NCF,'DIAG', 'MANEIG') CALL dinit (ncf, 0.d0, diag, 1) - IF (LDISC) THEN -!----------------------------------------------------------------------- + IF (LDISC) THEN +!----------------------------------------------------------------------- ! ! (2.2.1) - DVDSON --- Disk, load diagonal ! !------------------------------------------------------- IF (myid == 0) THEN - WRITE (*, *) ' matrix stored on disc;' - WRITE (24, *) ' matrix stored on disc;' + WRITE (*, *) ' matrix stored on disc;' + WRITE (24, *) ' matrix stored on disc;' END IF - + ! Disk storage; necessarily sparse; one column of the matrix in ! memory - - IMV = 1 - + + IMV = 1 + ! Load diagonal - Each node will have the same, complete copy ! after this if block - print *, myid, 'Reading diagonal, unit imcdf =', imcdf - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + print *, myid, 'Reading diagonal, unit imcdf =', imcdf + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'maneig:2' - - DO I = MYID + 1, NCF, NPROCS + 'maneig:2' + + DO I = MYID + 1, NCF, NPROCS READ (IMCDF) NELC, ELSTO, (dummy,IR=2,NELC), DIATMP, & (idummy, ir=1,nelc) - DIAG(I) = DIATMP - EAV - END DO - print *, ' finished' - ELSE -!----------------------------------------------------------------------- + DIAG(I) = DIATMP - EAV + END DO + print *, ' finished' + ELSE +!----------------------------------------------------------------------- ! ! (2.2.2) - DVDSON --- Memory, load all ! @@ -347,10 +347,10 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! ! Core storage; load matrix into memory ! - LDISC = .FALSE. - IF (SPARSE) THEN -!----------------------------------------------------------------------- - + LDISC = .FALSE. + IF (SPARSE) THEN +!----------------------------------------------------------------------- + ! (2.2.2.1) - DVDSON --- Memory, load all, sparse ! !------------------------------------------------------- @@ -358,28 +358,28 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) WRITE (24, *) ' sparse matrix stored in memory' WRITE ( *, *) ' sparse matrix stored in memory' END IF - - IMV = 2 - WRITE (6, *) 'nelmnt = ', NELMNT - CALL ALLOC (EMT, NELMNT, 'EMT', 'MANEIG') - CALL ALLOC (IROW, NELMNT, 'IROW', 'MANEIG') - CALL ALLOC (IENDC, 0, NCF , 'IENDC', 'MANEIG') - IOFSET = 0 - IENDC(0) = 0 - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + IMV = 2 + WRITE (6, *) 'nelmnt = ', NELMNT + CALL ALLOC (EMT, NELMNT, 'EMT', 'MANEIG') + CALL ALLOC (IROW, NELMNT, 'IROW', 'MANEIG') + CALL ALLOC (IENDC, 0, NCF , 'IENDC', 'MANEIG') + IOFSET = 0 + IENDC(0) = 0 + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) & - STOP 'maneig:3' - DO I = MYID + 1, NCF, NPROCS + STOP 'maneig:3' + DO I = MYID + 1, NCF, NPROCS READ (IMCDF) NELC, ELSTO, (EMT(IR+IOFSET),IR=1,NELC), (& - IROW(IR + IOFSET),IR=1,NELC) - EMT(NELC+IOFSET) = EMT(NELC+IOFSET) - EAV - DIAG(I) = EMT(NELC+IOFSET) - IOFSET = IOFSET + NELC - IENDC(I) = IOFSET - END DO - ELSE -!----------------------------------------------------------------------- + IROW(IR + IOFSET),IR=1,NELC) + EMT(NELC+IOFSET) = EMT(NELC+IOFSET) - EAV + DIAG(I) = EMT(NELC+IOFSET) + IOFSET = IOFSET + NELC + IENDC(I) = IOFSET + END DO + ELSE +!----------------------------------------------------------------------- ! ! (2.2.2.2) - DVDSON --- Memory, load all, dense ! @@ -388,49 +388,49 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) WRITE (24,*) ' full matrix stored in in memory' WRITE ( *,*) ' full matrix stored in in memory' END IF - - IMV = 3 - + + IMV = 3 + ! Find NDENSE_L, the number of elements on the node (dense form) - - NDENSE_L = 0 - DO I = MYID + 1, NCF, NPROCS - NDENSE_L = NDENSE_L + I - END DO - - CALL ALLOC (EMT, NDENSE_L, 'EMT', 'MANEIG') - CALL DINIT (NDENSE_L, 0.0D00, EMT, 1) - CALL ALLOC (WORK, NCF, 'WORK', 'MANEIG') - CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + + NDENSE_L = 0 + DO I = MYID + 1, NCF, NPROCS + NDENSE_L = NDENSE_L + I + END DO + + CALL ALLOC (EMT, NDENSE_L, 'EMT', 'MANEIG') + CALL DINIT (NDENSE_L, 0.0D00, EMT, 1) + CALL ALLOC (WORK, NCF, 'WORK', 'MANEIG') + CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG') + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) & - STOP 'maneig:4' - - IOFSET = 0 - DO I = MYID + 1, NCF, NPROCS + STOP 'maneig:4' + + IOFSET = 0 + DO I = MYID + 1, NCF, NPROCS READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),& - IR=1,NELC) - WORK(NELC) = WORK(NELC) - EAV - DIAG(I) = WORK(NELC) - DO IR = 1, NELC - EMT(IOFSET+IROW(IR)) = WORK(IR) - END DO - IOFSET = IOFSET + I - END DO - CALL DALLOC (WORK, 'WORK', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') - - ENDIF + IR=1,NELC) + WORK(NELC) = WORK(NELC) - EAV + DIAG(I) = WORK(NELC) + DO IR = 1, NELC + EMT(IOFSET+IROW(IR)) = WORK(IR) + END DO + IOFSET = IOFSET + I + END DO + CALL DALLOC (WORK, 'WORK', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') + + ENDIF ! ...Memory mode - sparse or dense -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! (2.2.2.3e) *** E n d o f D V D S O N m e m o r y -!----------------------------------------------------------------------- - ENDIF +!----------------------------------------------------------------------- + ENDIF ! ...Disk or Memory -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! (2.2.3e) *** E n d o f D V D S O N -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! Make diagonals global, no matter it is disk or memory mode @@ -440,57 +440,57 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! the expression below; the value of LIM can be reduced to NVECMX ! plus a smaller number if storage is severely constrained ! - LIM = MIN(NCF,2*NVECMX + 60) + LIM = MIN(NCF,2*NVECMX + 60) ! lwork = 2*ncf*lim + lim*lim + (nvecmx+10)*lim + nvecmx - LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECMX - CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') + LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECMX + CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') work(1:lwork) = 0.0d0 - LIWORK = 6*LIM + NVECMX - CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') + LIWORK = 6*LIM + NVECMX + CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') !*changed by Misha 02/12/97 - CRITE = 1.0D-17 -!GG CRITC = 1.0D-08 -!GG CRITR = 1.0D-08 -!GG ORTHO = MAX(1D-8,CRITR) - CRITC = 1.0D-09 - CRITR = 1.0D-09 - ORTHO = MAX(1D-9,CRITR) + CRITE = 1.0D-17 +!GG CRITC = 1.0D-08 +!GG CRITR = 1.0D-08 +!GG ORTHO = MAX(1D-8,CRITR) + CRITC = 1.0D-09 + CRITR = 1.0D-09 + ORTHO = MAX(1D-9,CRITR) ! end of changes - + ! maxitr = MAX (nvecmx*100, ncf/10) - MAXITR = MAX(NVECMX*100,NCF/10) + MAXITR = MAX(NVECMX*100,NCF/10) !maxitr = MIN (nvect*100, ncf) ! FROM RSCFVU !!! - CALL ALLOC (JWORK, LIM,'JWORK', 'MANEIG' ) - - CALL ALLOC (EVAL, NVECMX, 'EVAL', 'MANEIG') - CALL ALLOC (EVEC, NCF*NVECMX, 'EVEC', 'MANEIG') - - DMUNGO = 10.D99 - CALL DINIT (NVECMX, DMUNGO, EVAL, 1) - + CALL ALLOC (JWORK, LIM,'JWORK', 'MANEIG' ) + + CALL ALLOC (EVAL, NVECMX, 'EVAL', 'MANEIG') + CALL ALLOC (EVEC, NCF*NVECMX, 'EVEC', 'MANEIG') + + DMUNGO = 10.D99 + CALL DINIT (NVECMX, DMUNGO, EVAL, 1) + ! Compute the eigenpairs in each block - - NVEX = NVECMX - IF (LDISC) THEN - MBLOCK = NVEX - ELSE - MBLOCK = 1 - ENDIF - NEND = NCF*NVEX - - ILOW = 1 - IHIGH = NVEX - NIV = NVEX -!************************************************************************ + + NVEX = NVECMX + IF (LDISC) THEN + MBLOCK = NVEX + ELSE + MBLOCK = 1 + ENDIF + NEND = NCF*NVEX + + ILOW = 1 + IHIGH = NVEX + NIV = NVEX +!************************************************************************ ! ! Call Davidson eigensolver ! - SELECT CASE (IMV) - CASE (1) + SELECT CASE (IMV) + CASE (1) !******************** sparse and matrix on disk ********************** IF (myid .EQ. 0) print *, ' Sparse - Disk, iniestsd' - CALL POSFILE (0, IMCDF, NPOSITION)! was within iniestsd before - CALL INIESTSD (IOLPCK, NCF, MYID, NPROCS, NIV, WORK, IMCDF, EAV) + CALL POSFILE (0, IMCDF, NPOSITION)! was within iniestsd before + CALL INIESTSD (IOLPCK, NCF, MYID, NPROCS, NIV, WORK, IMCDF, EAV) print *, 'Returned from iniestsd ' if (ncf.gt. IOLPCK) then print *, 'Calling GDVD' @@ -498,9 +498,9 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) JWORK,NIV,MBLOCK,CRITE,CRITC, CRITR,ORTHO,MAXITR, & WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS, & NMV,IERR) - end if - - CASE (2) + end if + + CASE (2) !******************** sparse and matrix in memory ******************** IF (myid .EQ. 0) print *, ' Sparse - Memory, iniestmpi' CALL iniestmpi (IOLPCK, NCF,NIV,WORK,EMT,IENDC,IROW) @@ -510,12 +510,12 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS, & NMV,IERR) end if - - CALL DALLOC (EMT, 'EMT', 'MANEIG') - CALL DALLOC (IROW, 'IROW', 'MANEIG') - CALL DALLOC (IENDC, 'IENDC', 'MANEIG') - - CASE (3) + + CALL DALLOC (EMT, 'EMT', 'MANEIG') + CALL DALLOC (IROW, 'IROW', 'MANEIG') + CALL DALLOC (IENDC, 'IENDC', 'MANEIG') + + CASE (3) !*************************** dense and in memory ********************** IF (myid .EQ. 0) print *, ' Dense - Memory, iniestdm' CALL INIESTDM (IOLPCK,NCF,NIV,WORK,EMT) @@ -525,59 +525,59 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS, & NMV,IERR) end if - CALL DALLOC (EMT, 'EMT', 'MANEIG') - END SELECT -!************************************************************************ - CALL DALLOC (DIAG, 'DIAG', 'MANEIG') - CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL DALLOC (JWORK, 'JWORK', 'MANEIG') - IF (myid .EQ. 0) THEN - WRITE (24, *) ' ', NLOOPS, ' iterations;' - WRITE (24, *) ' ', NMV, ' matrix-vector multiplies.' + CALL DALLOC (EMT, 'EMT', 'MANEIG') + END SELECT +!************************************************************************ + CALL DALLOC (DIAG, 'DIAG', 'MANEIG') + CALL DALLOC (IWORK, 'IWORK', 'MANEIG') + CALL DALLOC (JWORK, 'JWORK', 'MANEIG') + IF (myid .EQ. 0) THEN + WRITE (24, *) ' ', NLOOPS, ' iterations;' + WRITE (24, *) ' ', NMV, ' matrix-vector multiplies.' + ENDIF + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'MANEIG: Returned from DVDSON with' + WRITE (ISTDE, *) ' IERR = ', IERR, '.' + STOP 'maneig: DVDSON wrong' ENDIF - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'MANEIG: Returned from DVDSON with' - WRITE (ISTDE, *) ' IERR = ', IERR, '.' - STOP 'maneig: DVDSON wrong' - ENDIF - + ! Put the eigenpairs in order, overwriting as necessary - - CALL DCOPY (NVEX, WORK(NEND+1), 1, EVAL, 1) - CALL DCOPY (NCF*NVEX, WORK(1), 1, EVEC, 1) - CALL DALLOC (WORK, 'WORK', 'MANEIG') - + + CALL DCOPY (NVEX, WORK(NEND+1), 1, EVAL, 1) + CALL DCOPY (NCF*NVEX, WORK(1), 1, EVEC, 1) + CALL DALLOC (WORK, 'WORK', 'MANEIG') + ! Rearrange and reallocate storage for the eigenpairs ! as necessary - - IF (NVEC < NVECMX) THEN - CALL ALLOC (IWORK, NVECMX, 'IWORK', 'MANEIG') - DO I = 1, NVECMX - IWORK(I) = I - END DO - DO I = 1, NVEC - IOFSET = IVEC(I) - LOC = IWORK(I) - IF (IOFSET == LOC) CYCLE - CALL DSWAP (1, EVAL(IOFSET), 1, EVAL(I), 1) - IWORK(I) = IWORK(IOFSET) - IWORK(IOFSET) = LOC - IOFSET = NCF*(IOFSET - 1) - LOC = NCF*(I - 1) - CALL DSWAP (NCF, EVEC(IOFSET+1), 1, EVEC(LOC+1), 1) - END DO - CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL RALLOC (EVAL, NVEC, 'EVAL', 'MANEIG') - CALL RALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG' ) - - ENDIF - - ENDIF -! (2.3e) *** E N D O F N O N - T R I V I A L C A S E - - ENDIF + + IF (NVEC < NVECMX) THEN + CALL ALLOC (IWORK, NVECMX, 'IWORK', 'MANEIG') + DO I = 1, NVECMX + IWORK(I) = I + END DO + DO I = 1, NVEC + IOFSET = IVEC(I) + LOC = IWORK(I) + IF (IOFSET == LOC) CYCLE + CALL DSWAP (1, EVAL(IOFSET), 1, EVAL(I), 1) + IWORK(I) = IWORK(IOFSET) + IWORK(IOFSET) = LOC + IOFSET = NCF*(IOFSET - 1) + LOC = NCF*(I - 1) + CALL DSWAP (NCF, EVEC(IOFSET+1), 1, EVEC(LOC+1), 1) + END DO + CALL DALLOC (IWORK, 'IWORK', 'MANEIG') + CALL RALLOC (EVAL, NVEC, 'EVAL', 'MANEIG') + CALL RALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG' ) + + ENDIF + + ENDIF +! (2.3e) *** E N D O F N O N - T R I V I A L C A S E + + ENDIF ! (3e) *** E N D O F A L L - + !-------------------------------------------------------------------- ! Only the following quantities are needed after this routine is ! finished: @@ -586,30 +586,30 @@ SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a) ! ! Clean up eigenvectors; determine their J/P values ! - DO J = 1, NVEC - + DO J = 1, NVEC + ! Find the dominant component of each eigenvector - - IOFSET = (J - 1)*NCF - - AMAX = 0.D0 - DO I = 1, NCF - WA = ABS(EVEC(I+IOFSET)) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO - -! Find the angular momentum and parity of the dominant component - - IATJPO = ITJPO(IA) - IASPAR = ISPAR(IA) - + + IOFSET = (J - 1)*NCF + + AMAX = 0.D0 + DO I = 1, NCF + WA = ABS(EVEC(I+IOFSET)) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO + +! Find the angular momentum and parity of the dominant component + + IATJPO = ITJPO(IA) + IASPAR = ISPAR(IA) + ! Change sign of eigenvactor if dominant component is negative - - IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE - EVEC(1+IOFSET:NCF+IOFSET) = -EVEC(1+IOFSET:NCF+IOFSET) - END DO - - RETURN - END SUBROUTINE MANEIG + + IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE + EVEC(1+IOFSET:NCF+IOFSET) = -EVEC(1+IOFSET:NCF+IOFSET) + END DO + + RETURN + END SUBROUTINE MANEIG diff --git a/src/appl/rci90_mpi/maneigmpi_I.f90 b/src/appl/rci90_mpi/maneigmpi_I.f90 index 94a99058b..011557aa7 100644 --- a/src/appl/rci90_mpi/maneigmpi_I.f90 +++ b/src/appl/rci90_mpi/maneigmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE maneig_I + MODULE maneig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maneig (IATJPO, IASPAR, NELMNT_a) + SUBROUTINE maneig (IATJPO, IASPAR, NELMNT_a) USE vast_kind_param, ONLY: LONG - INTEGER, INTENT(OUT) :: IATJPO - INTEGER, INTENT(OUT) :: IASPAR + INTEGER, INTENT(OUT) :: IATJPO + INTEGER, INTENT(OUT) :: IASPAR INTEGER(LONG) :: NELMNT_a - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/matrix.f90 b/src/appl/rci90_mpi/matrix.f90 index bc8f6873f..9eea8fb6a 100644 --- a/src/appl/rci90_mpi/matrix.f90 +++ b/src/appl/rci90_mpi/matrix.f90 @@ -16,8 +16,8 @@ SUBROUTINE MATRIX (ncore, j2max) ! Block version Xinghong He Last revision: 12 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -38,9 +38,9 @@ SUBROUTINE MATRIX (ncore, j2max) USE stat_C USE wave_C USE where_C - USE blim_C + USE blim_C USE eigvec1_C - USE iccu_C + USE iccu_C USE cteilsrk_C USE coeils_C USE bilst_C @@ -74,7 +74,7 @@ SUBROUTINE MATRIX (ncore, j2max) !----------------------------------------------- REAL(DOUBLE), DIMENSION(NNNW) :: slfint CHARACTER(LEN=8) :: CNUM - REAL(DOUBLE) :: atwinv, elsto, eau, ecm, eev, elemnt + REAL(DOUBLE) :: atwinv, elsto, eau, ecm, eev, elemnt REAL(DOUBLE), DIMENSION(:), pointer :: slf_en, ucf, etot INTEGER(LONG) :: nelmnt_a INTEGER :: iiatjpo, iiaspar @@ -82,19 +82,19 @@ SUBROUTINE MATRIX (ncore, j2max) !----------------------------------------------- ! ...Common to all blocks - place here to save CPU time CALL auxblk (j2max, atwinv) - + !*************************************************************** ! Loop over blocks !*************************************************************** ncminpas = 0 - + DO 100 jblock = 1, nblock ncf = ncfblk(jblock) nvec = nevblk(jblock) nvecmx = ncmaxblk(jblock) iccut(1) = iccutblk(jblock) !.. Determine position of the previous block in the .res file - + nposition = 7 + nw + nw ! File position of the previous block ! in the .res file DO i = 1, jblock - 1 @@ -102,11 +102,11 @@ SUBROUTINE MATRIX (ncore, j2max) IF (ncfblk(i) .LT. nprocs) j = ncfblk(i) / (myid+1) nposition = nposition + j + 1 ENDDO - + !.. SETHAM does not handle this extrem case IF (nprocs .GT. NCF) & CALL stopmpi ('matrix: too many nodes', myid) - + ! ...Obtain ivec() from iccmin() IF (nvec .GT. 0) THEN CALL alloc (ivec, nvec, 'IVEC', 'MATRIX') @@ -115,7 +115,7 @@ SUBROUTINE MATRIX (ncore, j2max) ENDDO ncminpas = ncminpas + nvec ENDIF - + ! ...These 3 were allocated in lodcsh2 and deallocated at the end ! ... of this routine and in the setham. In this block version, ! ... both allocation and deallocation are placed here. See the @@ -128,11 +128,11 @@ SUBROUTINE MATRIX (ncore, j2max) do ic=1,ncf SLF_EN(IC) = 0.0 enddo - + ! ...Load CSF list of the current block CALL lodcslmpi (21, ncore, jblock) ! zou - + IF (LSE) THEN IF (myid .EQ. 0) THEN PRINT *, 'Entering QED ...' @@ -156,7 +156,7 @@ SUBROUTINE MATRIX (ncore, j2max) //' --- these will influence the data' WRITE (24,*) ' in the RCI92 MIXing coefficients File.' endif - ENDIF + ENDIF ! zou IF (nvec <= 0) THEN @@ -202,15 +202,15 @@ SUBROUTINE MATRIX (ncore, j2max) ! added to EAV which was later substracted from H. Thus at ! this point, EAV is correct (it has ELSTO added), EVAL() ! need ELSTO and the correct EAV. - IF (NCF > 1) then + IF (NCF > 1) then DO i = 1, NVEC EVAL(i) = EVAL(i) + ELSTO ENDDO END IF - + CALL ENGOUT (EAV,EVAL,IiATJPO,iIASPAR,IVEC,NVEC,3) CALL WGHTD5 (iiatjpo, iiaspar) - + ! ...Write ASF symmetries, eigenvalues, and eigenvectors to RCI92 ! ...MIXing coefficients File; close the file; print a report WRITE (25) jblock, ncf, nvec, iiatjpo, iiaspar @@ -238,7 +238,7 @@ SUBROUTINE MATRIX (ncore, j2max) IF (.not.LSE) THEN IF (myid .EQ. 0) PRINT *, 'Entering QED ...' CALL ALLOC (ETOT,NVEC,'ETOT', 'MATRIX') - IF (myid .EQ. 0) THEN + IF (myid .EQ. 0) THEN WRITE (24,*) WRITE (24,*) ' Self Energy Corrections: ' WRITE (24,*) @@ -266,7 +266,7 @@ SUBROUTINE MATRIX (ncore, j2max) WRITE (24,302) j,LABJ(IiATJPO),LABP(IP),EAU,ECM,EEV ! ENDDO - IF (myid .EQ. 0) THEN + IF (myid .EQ. 0) THEN WRITE (24,*) WRITE (24,*) 'Self-energy corrections estimated' & //' --- these do not influence the data' @@ -276,22 +276,22 @@ SUBROUTINE MATRIX (ncore, j2max) ENDIF CALL dalloc (ETOT, 'ETOT', 'MATRIX') ENDIF - + ! ...Locals CALL dalloc (ivec, 'IVEC', 'MATRIX') ! ...Allocated in maneig CALL dalloc (eval, 'EVAL', 'MATRIX') CALL dalloc (evec, 'EVEC', 'MATRIX') - + 80 CONTINUE - + ! ...Locals CALL dalloc (IQA, 'IQA', 'MATRIX') CALL dalloc (JQSA, 'JQSA', 'MATRIX') CALL dalloc (JCUPA, 'JCUPA', 'MATRIX') CALL dalloc (SLF_EN, 'SLF_EN', 'MATRIX') CALL dalloc (UCF, 'UCF', 'MATRIX') - + 100 CONTINUE ! ! Close the restart files; nothing will be added to them now @@ -303,7 +303,7 @@ SUBROUTINE MATRIX (ncore, j2max) CALL dalloc (ncmaxblk, 'NCMAXBLK', 'MATRIX') CALL dalloc (iccutblk, 'ICUTTBLK', 'MATRIX') CALL dalloc (iccmin, 'ICCMIN', 'MATRIX') ! allocated in items as pnccmin - + CALL dalloc (VALTEIRK, 'VALTEIRK', 'MATRIX') ! allocated in genintrk CALL dalloc (INDTEIRK, 'INDTEIRK', 'MATRIX') ! allocated in genintrk ! @@ -372,10 +372,10 @@ SUBROUTINE MATRIX (ncore, j2max) CALL DALLOC (VALVPI, 'VALVPI', 'MATRIX') ENDIF ENDIF - + CALL dalloc (PF, 'PF', 'MATRIX') ! lodrwf or lodres CALL dalloc (QF, 'QF', 'MATRIX') ! lodrwf or lodres - + RETURN - + END diff --git a/src/appl/rci90_mpi/matrix_I.f90 b/src/appl/rci90_mpi/matrix_I.f90 index 3b8bca184..ecf4d6e52 100644 --- a/src/appl/rci90_mpi/matrix_I.f90 +++ b/src/appl/rci90_mpi/matrix_I.f90 @@ -1,10 +1,10 @@ - MODULE matrix_I + MODULE matrix_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE MATRIX (ncore, j2max) INTEGER, INTENT(IN):: ncore, j2max - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/mohr.f90 b/src/appl/rci90_mpi/mohr.f90 index 658b969d4..8db7132b6 100644 --- a/src/appl/rci90_mpi/mohr.f90 +++ b/src/appl/rci90_mpi/mohr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) + SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! * ! The function F (Z*alpha) for the 1s 2s 2p- 2p symmetries * ! is computed here. A value is obtained by interpolating in, or * @@ -12,35 +12,35 @@ SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE interp_I + USE interp_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: N - INTEGER , INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE) , INTENT(OUT) :: FZALFA + INTEGER , INTENT(IN) :: N + INTEGER , INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE) , INTENT(OUT) :: FZALFA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- ! Number of data points - INTEGER, PARAMETER :: NUMVAL = 12 + INTEGER, PARAMETER :: NUMVAL = 12 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE), DIMENSION(NUMVAL) :: VAL1S, VAL2S, VAL2P1, VAL2P3, ARG - REAL(DOUBLE) :: ACCY, VALUE + REAL(DOUBLE), DIMENSION(NUMVAL) :: VAL1S, VAL2S, VAL2P1, VAL2P3, ARG + REAL(DOUBLE) :: ACCY, VALUE !----------------------------------------------- ! ! @@ -48,73 +48,73 @@ SUBROUTINE MOHR(N, KAPPA, Z, FZALFA) ! DATA VAL1S/ 10.3168D00, 4.6540D00, 3.2460D00, 2.5519D00, 2.1351D00, & 1.8644D00, 1.6838D00, 1.5675D00, 1.5032D00, 1.4880D00, 1.5317D00, & - 1.6614D00/ + 1.6614D00/ ! ! 2s data: ! DATA VAL2S/ 10.5468D00, 4.8930D00, 3.5063D00, 2.8391D00, 2.4550D00, & 2.2244D00, 2.0948D00, 2.0435D00, 2.0650D00, 2.1690D00, 2.3870D00, & - 2.7980D00/ + 2.7980D00/ ! ! 2p- data: ! DATA VAL2P1/ -0.1264D00, -0.1145D00, -0.0922D00, -0.0641D00, -0.0308D00, & 0.0082D00, 0.0549D00, 0.1129D00, 0.1884D00, 0.2934D00, 0.4530D00, & - 0.7250D00/ + 0.7250D00/ ! ! 2p data: ! DATA VAL2P3/ 0.1235D00, 0.1303D00, 0.1436D00, 0.1604D00, 0.1794D00, & 0.1999D00, 0.2215D00, 0.2440D00, 0.2671D00, 0.2906D00, 0.3141D00, & - 0.3367D00/ + 0.3367D00/ ! ! Z data: ! DATA ARG/ 1.0D00, 10.0D00, 20.0D00, 30.0D00, 40.0D00, 50.0D00, 60.0D00, & - 70.0D00, 80.0D00, 90.0D00, 100.0D00, 110.0D00/ + 70.0D00, 80.0D00, 90.0D00, 100.0D00, 110.0D00/ ! !----------------------------------------------------------------------* ! ! Convergence criterion for interpolation ! - DATA ACCY/ 1.0D-03/ + DATA ACCY/ 1.0D-03/ ! ! Interpolate or issue error message as appropriate ! - IF (N == 1) THEN - IF (KAPPA == (-1)) THEN - CALL INTERP (ARG, VAL1S, NUMVAL, Z, VALUE, ACCY) - ELSE - WRITE (*, 300) - WRITE (*, 301) N, KAPPA - STOP - ENDIF - ELSE IF (N == 2) THEN - SELECT CASE (KAPPA) - CASE (-1) - CALL INTERP (ARG, VAL2S, NUMVAL, Z, VALUE, ACCY) - CASE (1) - CALL INTERP (ARG, VAL2P1, NUMVAL, Z, VALUE, ACCY) - CASE (-2) - CALL INTERP (ARG, VAL2P3, NUMVAL, Z, VALUE, ACCY) - CASE DEFAULT - WRITE (*, 300) - WRITE (*, 301) N, KAPPA - STOP - END SELECT - ELSE - WRITE (*, 300) - WRITE (*, 302) N - STOP - ENDIF -! - FZALFA = VALUE -! - RETURN -! - 300 FORMAT('MOHR:') - 301 FORMAT(' Principal quantum number, ',I12,', kappa, ',1I3,'.') - 302 FORMAT(' Principal quantum number, ',1I2,', Should be either 1 or 2.') - RETURN -! - END SUBROUTINE MOHR + IF (N == 1) THEN + IF (KAPPA == (-1)) THEN + CALL INTERP (ARG, VAL1S, NUMVAL, Z, VALUE, ACCY) + ELSE + WRITE (*, 300) + WRITE (*, 301) N, KAPPA + STOP + ENDIF + ELSE IF (N == 2) THEN + SELECT CASE (KAPPA) + CASE (-1) + CALL INTERP (ARG, VAL2S, NUMVAL, Z, VALUE, ACCY) + CASE (1) + CALL INTERP (ARG, VAL2P1, NUMVAL, Z, VALUE, ACCY) + CASE (-2) + CALL INTERP (ARG, VAL2P3, NUMVAL, Z, VALUE, ACCY) + CASE DEFAULT + WRITE (*, 300) + WRITE (*, 301) N, KAPPA + STOP + END SELECT + ELSE + WRITE (*, 300) + WRITE (*, 302) N + STOP + ENDIF +! + FZALFA = VALUE +! + RETURN +! + 300 FORMAT('MOHR:') + 301 FORMAT(' Principal quantum number, ',I12,', kappa, ',1I3,'.') + 302 FORMAT(' Principal quantum number, ',1I2,', Should be either 1 or 2.') + RETURN +! + END SUBROUTINE MOHR diff --git a/src/appl/rci90_mpi/mohr_I.f90 b/src/appl/rci90_mpi/mohr_I.f90 index cf0be8319..63d6e8e2f 100644 --- a/src/appl/rci90_mpi/mohr_I.f90 +++ b/src/appl/rci90_mpi/mohr_I.f90 @@ -1,16 +1,16 @@ - MODULE mohr_I + MODULE mohr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mohr (N, KAPPA, Z, FZALFA) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NUMVAL - PARAMETER (NUMVAL = 12) - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE), INTENT(OUT) :: FZALFA - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mohr (N, KAPPA, Z, FZALFA) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NUMVAL + PARAMETER (NUMVAL = 12) + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE), INTENT(OUT) :: FZALFA + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/ncharg.f90 b/src/appl/rci90_mpi/ncharg.f90 index 9b090c61a..123bcfd49 100644 --- a/src/appl/rci90_mpi/ncharg.f90 +++ b/src/appl/rci90_mpi/ncharg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NCHARG + SUBROUTINE NCHARG ! * ! This routine evaluates the nuclear charge density, and stores it * ! in the common array ZDIST . * @@ -10,13 +10,13 @@ SUBROUTINE NCHARG ! Written by Farid A Parpia, at Oxford Last updated: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: pi, z, precis USE grid_C USE npar_C @@ -25,57 +25,57 @@ SUBROUTINE NCHARG !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE es_I + USE es_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I REAL(DOUBLE) :: C, A, CBA, PI2, ABC, ABC2, ABC3, S2MCBA, S3MCBA, EN,& - ZNORM, EXTRM, ZDISTI - LOGICAL :: FORM1, FORM2 + ZNORM, EXTRM, ZDISTI + LOGICAL :: FORM1, FORM2 !----------------------------------------------- ! ! ! Initialize array to zero ! - ZDIST(:N) = 0.0D00 + ZDIST(:N) = 0.0D00 ! ! Fermi charge distribution ! - IF (NPARM == 2) THEN - C = PARM(1) - A = PARM(2) - CBA = C/A - PI2 = PI*PI - ABC = A/C - ABC2 = ABC*ABC - ABC3 = ABC2*ABC - CALL ES ((-CBA), S2MCBA, S3MCBA) - EN = 1.0D00 + PI2*ABC2 - 6.0D00*ABC3*S3MCBA - ZNORM = 3.0D00*Z/(4.0D00*PI*EN*C**3) - FORM1 = .TRUE. - FORM2 = .FALSE. - DO I = 1, N - IF (FORM1) THEN - EXTRM = DEXP((R(I)-C)/A) - ZDIST(I) = ZNORM/(1.0D00 + EXTRM) - IF (1.0D00/EXTRM <= PRECIS) THEN - FORM1 = .FALSE. - FORM2 = .TRUE. - ENDIF - ELSE IF (FORM2) THEN - ZDISTI = ZNORM*DEXP((-(R(I)-C)/A)) - IF (DABS(ZDISTI) > 0.0D00) THEN - ZDIST(I) = ZDISTI - ELSE - MTP = I - EXIT - ENDIF - ENDIF - END DO - ENDIF + IF (NPARM == 2) THEN + C = PARM(1) + A = PARM(2) + CBA = C/A + PI2 = PI*PI + ABC = A/C + ABC2 = ABC*ABC + ABC3 = ABC2*ABC + CALL ES ((-CBA), S2MCBA, S3MCBA) + EN = 1.0D00 + PI2*ABC2 - 6.0D00*ABC3*S3MCBA + ZNORM = 3.0D00*Z/(4.0D00*PI*EN*C**3) + FORM1 = .TRUE. + FORM2 = .FALSE. + DO I = 1, N + IF (FORM1) THEN + EXTRM = DEXP((R(I)-C)/A) + ZDIST(I) = ZNORM/(1.0D00 + EXTRM) + IF (1.0D00/EXTRM <= PRECIS) THEN + FORM1 = .FALSE. + FORM2 = .TRUE. + ENDIF + ELSE IF (FORM2) THEN + ZDISTI = ZNORM*DEXP((-(R(I)-C)/A)) + IF (DABS(ZDISTI) > 0.0D00) THEN + ZDIST(I) = ZDISTI + ELSE + MTP = I + EXIT + ENDIF + ENDIF + END DO + ENDIF ! - RETURN + RETURN ! - END SUBROUTINE NCHARG + END SUBROUTINE NCHARG diff --git a/src/appl/rci90_mpi/ncharg_I.f90 b/src/appl/rci90_mpi/ncharg_I.f90 index 316f869cc..0feb4f532 100644 --- a/src/appl/rci90_mpi/ncharg_I.f90 +++ b/src/appl/rci90_mpi/ncharg_I.f90 @@ -1,9 +1,9 @@ - MODULE ncharg_I + MODULE ncharg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ncharg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ncharg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/qed.f90 b/src/appl/rci90_mpi/qed.f90 index 8d3786e09..c0c47080d 100644 --- a/src/appl/rci90_mpi/qed.f90 +++ b/src/appl/rci90_mpi/qed.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QED(JSTATE, SLFINT, UCF) + SUBROUTINE QED(JSTATE, SLFINT, UCF) ! * ! This routine estimates corrections to the energy levels due to * ! self-energy. * @@ -12,13 +12,13 @@ SUBROUTINE QED(JSTATE, SLFINT, UCF) ! Modified by Xinghong He Last update: 24 Jun 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE def_C USE eigv_C @@ -32,97 +32,97 @@ SUBROUTINE QED(JSTATE, SLFINT, UCF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE ratden_I - USE fzalf_I + USE iq_I + USE ratden_I + USE fzalf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JSTATE - REAL(DOUBLE), INTENT(OUT) :: SLFINT(NNNW) - REAL(DOUBLE), INTENT(OUT) :: UCF(1) + INTEGER, INTENT(IN) :: JSTATE + REAL(DOUBLE), INTENT(OUT) :: SLFINT(NNNW) + REAL(DOUBLE), INTENT(OUT) :: UCF(1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MAXITER, J, I, II, NPJ, KAPPA, MFJ - REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP - REAL(DOUBLE) :: UCFJ, ZEFF, RATIO, VALU - CHARACTER :: NPCHAR, NAKCHAR*2 + INTEGER :: MAXITER, J, I, II, NPJ, KAPPA, MFJ + REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP + REAL(DOUBLE) :: UCFJ, ZEFF, RATIO, VALU + CHARACTER :: NPCHAR, NAKCHAR*2 !----------------------------------------------- ! ! Pre-set tolerable number for iteration in finding effective ! nuclear charge. ! - MAXITER = 20 + MAXITER = 20 ! ! Modified so that UCFJ describes the current eigenstate ! - DO J = 1, NW - UCFJ = 0.0D00 + DO J = 1, NW + UCFJ = 0.0D00 ! DO 3 I = 1,NVEC - I = JSTATE - DO II = 1, NCF - UCFJ = UCFJ + DBLE(IQ(J,II))*EVEC(II + (I - 1)*NCF)**2 - END DO + I = JSTATE + DO II = 1, NCF + UCFJ = UCFJ + DBLE(IQ(J,II))*EVEC(II + (I - 1)*NCF)**2 + END DO ! 3 CONTINUE ! print *, ucfj,'ucf' - UCF(J) = UCFJ + UCF(J) = UCFJ ! zou UCF(J) = UCFJ/DBLE (NCF) - END DO + END DO ! - DO J = 1, NW + DO J = 1, NW ! - NPJ = NP(J) + NPJ = NP(J) ! - IF (NPJ <= 8) THEN + IF (NPJ <= 8) THEN ! ! Only orbitals with principal quantum number 8 or less can ! be treated by this section of code ! - KAPPA = NAK(J) + KAPPA = NAK(J) ! ! Begin by transferring the function to a temporary array ! - MFJ = MF(J) + MFJ = MF(J) ! - PTEMP(1) = 0.0D00 - QTEMP(1) = 0.0D00 - DO I = 2, MFJ - PTEMP(I) = PF(I,J) - QTEMP(I) = QF(I,J) - END DO + PTEMP(1) = 0.0D00 + QTEMP(1) = 0.0D00 + DO I = 2, MFJ + PTEMP(I) = PF(I,J) + QTEMP(I) = QF(I,J) + END DO ! - ZEFF = Z - RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) - VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) + ZEFF = Z + RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) + VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) ! - SLFINT(J) = VALU*ZEFF**4/(PI*C**3) + SLFINT(J) = VALU*ZEFF**4/(PI*C**3) ! print *, 'No. orb.=',j,' Zeff = ',zeff ! & , 'Scale= ',ratio ! & , 'S.E. = ',slfint(j)*2*13.6058,slfint(j)/ratio*2*13.6058 ! - ELSE + ELSE ! ! The self-energy for orbitals with principal quantum number ! greater than 8 is set to zero ! - SLFINT(J) = 0.0D00 + SLFINT(J) = 0.0D00 ! - ENDIF + ENDIF ! - END DO + END DO ! ! Deallocate storage for the `generalised occupation numbers' ! ! - RETURN - END SUBROUTINE QED + RETURN + END SUBROUTINE QED !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) + REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) ! * ! This subprogram computes the overlap of the orbital tabulated in * ! the arrays P and Q with maximum tabulation point MTPO with * @@ -134,12 +134,12 @@ REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Switches: +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Switches: !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C USE horb_C, ONLY: ph, qh @@ -147,47 +147,47 @@ REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dcbsrw_I - USE quad_I + USE dcbsrw_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - REAL(DOUBLE), INTENT(IN) :: P(NNNP) - REAL(DOUBLE), INTENT(IN) :: Q(NNNP) + INTEGER , INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + REAL(DOUBLE), INTENT(IN) :: P(NNNP) + REAL(DOUBLE), INTENT(IN) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPH, I, K - REAL(DOUBLE) :: EH, PZH, RESULT, RESULT1 + INTEGER :: MTPH, I, K + REAL(DOUBLE) :: EH, PZH, RESULT, RESULT1 !----------------------------------------------- ! ! ! ! Set up the hydrogenic orbital ! - CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) + CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH) ! ! Compute the overlap ! - MTP = MIN(MTPH,MTPO) - DO I = 2, MTP - IF (RP(I) > 0.0219) CYCLE - K = I - END DO - MTP = K - TA(1) = 0.0D00 - TA(2:MTP) = (P(2:MTP)*P(2:MTP)+Q(2:MTP)*Q(2:MTP))*RP(2:MTP) + MTP = MIN(MTPH,MTPO) + DO I = 2, MTP + IF (RP(I) > 0.0219) CYCLE + K = I + END DO + MTP = K + TA(1) = 0.0D00 + TA(2:MTP) = (P(2:MTP)*P(2:MTP)+Q(2:MTP)*Q(2:MTP))*RP(2:MTP) ! TA(I) = (P(I)*PH(I)+Q(I)*QH(I))*RP(I) - CALL QUAD (RESULT) - TA(2:MTP) = (PH(2:MTP)*PH(2:MTP)+QH(2:MTP)*QH(2:MTP))*RP(2:MTP) - CALL QUAD (RESULT1) + CALL QUAD (RESULT) + TA(2:MTP) = (PH(2:MTP)*PH(2:MTP)+QH(2:MTP)*QH(2:MTP))*RP(2:MTP) + CALL QUAD (RESULT1) ! - RATDEN = RESULT/RESULT1 + RATDEN = RESULT/RESULT1 ! - RETURN - END FUNCTION RATDEN + RETURN + END FUNCTION RATDEN diff --git a/src/appl/rci90_mpi/qed_I.f90 b/src/appl/rci90_mpi/qed_I.f90 index f39d01a36..f618f4106 100644 --- a/src/appl/rci90_mpi/qed_I.f90 +++ b/src/appl/rci90_mpi/qed_I.f90 @@ -1,14 +1,14 @@ - MODULE qed_I + MODULE qed_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qed (JSTATE, SLFINT, UCF) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE qed (JSTATE, SLFINT, UCF) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - INTEGER, INTENT(IN) :: JSTATE - REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT - REAL(DOUBLE), DIMENSION(1), INTENT(OUT) :: UCF - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: JSTATE + REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT + REAL(DOUBLE), DIMENSION(1), INTENT(OUT) :: UCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/qed_slfen.f90 b/src/appl/rci90_mpi/qed_slfen.f90 index 1479616c9..bce6ad93c 100644 --- a/src/appl/rci90_mpi/qed_slfen.f90 +++ b/src/appl/rci90_mpi/qed_slfen.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QED_SLFEN(SLFINT) + SUBROUTINE QED_SLFEN(SLFINT) ! * ! This routine estimates the F(Z\alpha) function of self energy for * ! each orbital. * @@ -11,13 +11,13 @@ SUBROUTINE QED_SLFEN(SLFINT) ! Modified from subroutine QED by Yu Zou, Last update: 13 Mar 2000 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP USE def_C USE eigv_C @@ -30,8 +30,8 @@ SUBROUTINE QED_SLFEN(SLFINT) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ratden_I - USE fzalf_I + USE ratden_I + USE fzalf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -41,16 +41,16 @@ SUBROUTINE QED_SLFEN(SLFINT) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: MAXITER, J, NPJ, KAPPA, MFJ, I, NPJMAX -! REAL(DOUBLE), DIMENSION(1) :: UCF - REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP - REAL(DOUBLE) :: ZEFF, RATIO, VALU - CHARACTER :: NPCHAR, NAKCHAR*2 +! REAL(DOUBLE), DIMENSION(1) :: UCF + REAL(DOUBLE), DIMENSION(NNNP) :: PTEMP, QTEMP + REAL(DOUBLE) :: ZEFF, RATIO, VALU + CHARACTER :: NPCHAR, NAKCHAR*2 !----------------------------------------------- ! ! Pre-set tolerable number for iteration in finding effective ! nuclear charge. ! - MAXITER = 20 + MAXITER = 20 ! IF (myid .EQ. 0) THEN IF (NQEDCUT.EQ.1) THEN @@ -62,45 +62,45 @@ SUBROUTINE QED_SLFEN(SLFINT) CALL MPI_Bcast (NPJMAX,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) ! ! - DO J = 1, NW + DO J = 1, NW ! - NPJ = NP(J) + NPJ = NP(J) ! - IF (NPJ <= NPJMAX) THEN + IF (NPJ <= NPJMAX) THEN ! ! Only orbitals with principal quantum number 8 or less can ! be treated by this section of code ! - KAPPA = NAK(J) + KAPPA = NAK(J) ! ! Begin by transferring the function to a temporary array ! - MFJ = MF(J) + MFJ = MF(J) ! - PTEMP(1) = 0.0D00 - QTEMP(1) = 0.0D00 - DO I = 2, MFJ - PTEMP(I) = PF(I,J) - QTEMP(I) = QF(I,J) - END DO - ZEFF = Z - RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) - VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) - SLFINT(J) = VALU*ZEFF**4/(PI*C**3) + PTEMP(1) = 0.0D00 + QTEMP(1) = 0.0D00 + DO I = 2, MFJ + PTEMP(I) = PF(I,J) + QTEMP(I) = QF(I,J) + END DO + ZEFF = Z + RATIO = RATDEN(PTEMP,QTEMP,MFJ,NPJ,KAPPA,ZEFF) + VALU = RATIO*FZALF(NPJ,KAPPA,ZEFF)/DBLE(NPJ**3) + SLFINT(J) = VALU*ZEFF**4/(PI*C**3) ! - ELSE + ELSE ! ! The self-energy for orbitals with principal quantum number ! greater than 8 is set to zero ! - SLFINT(J) = 0.0D00 + SLFINT(J) = 0.0D00 ! - ENDIF + ENDIF ! - END DO + END DO ! ! Deallocate storage for the `generalised occupation numbers' ! ! - RETURN - END SUBROUTINE QED_SLFEN + RETURN + END SUBROUTINE QED_SLFEN diff --git a/src/appl/rci90_mpi/qed_slfen_I.f90 b/src/appl/rci90_mpi/qed_slfen_I.f90 index 069e3641a..fdaad9677 100644 --- a/src/appl/rci90_mpi/qed_slfen_I.f90 +++ b/src/appl/rci90_mpi/qed_slfen_I.f90 @@ -1,12 +1,12 @@ - MODULE qed_slfen_I + MODULE qed_slfen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE qed_slfen (SLFINT) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE qed_slfen (SLFINT) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW), INTENT(OUT) :: SLFINT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/ratden_I.f90 b/src/appl/rci90_mpi/ratden_I.f90 index be82c7a1b..0eb26ea58 100644 --- a/src/appl/rci90_mpi/ratden_I.f90 +++ b/src/appl/rci90_mpi/ratden_I.f90 @@ -1,17 +1,17 @@ - MODULE ratden_I + MODULE ratden_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION ratden (P, Q, MTPO, NP, KAPPA, Z) - USE vast_kind_param, ONLY: DOUBLE + REAL(KIND(0.0D0)) FUNCTION ratden (P, Q, MTPO, NP, KAPPA, Z) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q - INTEGER, INTENT(IN) :: MTPO - INTEGER :: NP - INTEGER :: KAPPA - REAL(DOUBLE) :: Z - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q + INTEGER, INTENT(IN) :: MTPO + INTEGER :: NP + INTEGER :: KAPPA + REAL(DOUBLE) :: Z + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/rci90mpi.f90 b/src/appl/rci90_mpi/rci90mpi.f90 index 8024caab0..d79a3d474 100644 --- a/src/appl/rci90_mpi/rci90mpi.f90 +++ b/src/appl/rci90_mpi/rci90mpi.f90 @@ -37,11 +37,11 @@ PROGRAM RCI90mpi ! Modified by Gediminas Gaigalas for new spin-angular integration. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE default_C USE blim_C @@ -58,36 +58,36 @@ PROGRAM RCI90mpi !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE cslhmpi_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setres_I - USE setmixmpi_I - USE strsum_I - USE factt_I - USE matrix_I + USE getyn_I + USE cslhmpi_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setres_I + USE setmixmpi_I + USE strsum_I + USE factt_I + USE matrix_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NBLK0 = 50 + INTEGER, PARAMETER :: NBLK0 = 50 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER, PARAMETER :: nblk=50 INTEGER :: lenperm, lentmp - INTEGER :: NCOUNT1, NCOUNT2, NCOUNT_RATE, NCOUNT_MAX - INTEGER, DIMENSION(8) :: NYMDUHMSM - INTEGER :: K, LENNAME, NCORE, NDUM, J2MAX, NSECONDS - LOGICAL :: YES + INTEGER :: NCOUNT1, NCOUNT2, NCOUNT_RATE, NCOUNT_MAX + INTEGER, DIMENSION(8) :: NYMDUHMSM + INTEGER :: K, LENNAME, NCORE, NDUM, J2MAX, NSECONDS + LOGICAL :: YES CHARACTER (LEN = 3) :: idstring -! CHARACTER(LEN=128) :: NAME, TMPDIR, PERMDIR, ISOFILE +! CHARACTER(LEN=128) :: NAME, TMPDIR, PERMDIR, ISOFILE CHARACTER(LEN=128) :: STARTDIR, NAME, ISOFILE, NAMESAVE,TMPDIR, PERMDIR - CHARACTER(LEN=8), DIMENSION(NBLK0) :: IDBLK - CHARACTER :: CHDATE*8, CHTIME*10, CHZONE*5, STR*8, MSG*128 + CHARACTER(LEN=8), DIMENSION(NBLK0) :: IDBLK + CHARACTER :: CHDATE*8, CHTIME*10, CHZONE*5, STR*8, MSG*128 !----------------------------------------------- !======================================================================= ! Start mpi --- get processor info: myid, nprocs, host name; and print @@ -106,18 +106,18 @@ PROGRAM RCI90mpi IF (myid .EQ. 0) THEN WRITE (istde,*) - WRITE (ISTDE, *) 'Default settings? ' - YES = GETYN() - IF (YES) THEN - NDEF = 0 + WRITE (ISTDE, *) 'Default settings? ' + YES = GETYN() + IF (YES) THEN + NDEF = 0 !cjb fort.734 !cjb write(734,'(A)') 'y ! Default settings' - ELSE - NDEF = 1 + ELSE + NDEF = 1 !cjb fort.734 !cjb write(734,'(A)') 'n ! Default settings' - ENDIF - ENDIF + ENDIF + ENDIF CALL MPI_Bcast (NDEF,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) ! CALL MPI_Bcast (imethod,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -209,14 +209,14 @@ PROGRAM RCI90mpi !======================================================================= ! Proceed with the CI calculation !======================================================================= - WRITE (6, *) 'Calling MATRIX...' - - CALL MATRIX (NCORE, J2MAX) - - IF (IPRERUN == 1) THEN - IPRERUN = 2 - GO TO 99 - ENDIF + WRITE (6, *) 'Calling MATRIX...' + + CALL MATRIX (NCORE, J2MAX) + + IF (IPRERUN == 1) THEN + IPRERUN = 2 + GO TO 99 + ENDIF !======================================================================= ! Execution finished; Statistics output !======================================================================= @@ -224,5 +224,5 @@ PROGRAM RCI90mpi CALL stopmpi2 (myid, nprocs, host, lenhost, & ncount1, 'RCI_MPI') - STOP + STOP END PROGRAM RCI90mpi diff --git a/src/appl/rci90_mpi/rkint.f90 b/src/appl/rci90_mpi/rkint.f90 index 450d7634f..518e2534b 100644 --- a/src/appl/rci90_mpi/rkint.f90 +++ b/src/appl/rci90_mpi/rkint.f90 @@ -12,13 +12,13 @@ REAL(KIND(0.0D0)) FUNCTION RKINT (RAC, IA, IC, RBD, IB, ID, K, IW) ! Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE bess_C USE debug_C @@ -29,65 +29,65 @@ REAL(KIND(0.0D0)) FUNCTION RKINT (RAC, IA, IC, RBD, IB, ID, K, IW) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE zkf_I - USE quad_I + USE zkf_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IA, IC - INTEGER, INTENT(IN) :: IB, ID - INTEGER :: K - INTEGER, INTENT(IN) :: IW + INTEGER :: IA, IC + INTEGER, INTENT(IN) :: IB, ID + INTEGER :: K + INTEGER, INTENT(IN) :: IW REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRBD, MXRAC, I - REAL(DOUBLE) :: RESULT + INTEGER :: MXRBD, MXRAC, I + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! MXRBD = MIN (MF(IB),MF(ID)) MXRAC = MIN (MF(IA),MF(IC)) ! - IF (IW == 0) THEN + IF (IW == 0) THEN ! ! IW = 0 ! - TA(:MXRAC) = RAC(:MXRAC) - MTP = MXRAC - CALL ZKF (K, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 - TA(2:MTP) = RBD(2:MTP)*TB(2:MTP)*RPOR(2:MTP) + TA(:MXRAC) = RAC(:MXRAC) + MTP = MXRAC + CALL ZKF (K, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 + TA(2:MTP) = RBD(2:MTP)*TB(2:MTP)*RPOR(2:MTP) ! - ELSE + ELSE ! ! IW = 1,2 ! - TA(:MXRAC) = RAC(:MXRAC)*(1.0D00 + BESSJ(1,IW,:MXRAC)) - MTP = MXRAC - CALL ZKF (K, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 + TA(:MXRAC) = RAC(:MXRAC)*(1.0D00 + BESSJ(1,IW,:MXRAC)) + MTP = MXRAC + CALL ZKF (K, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 TA(2:MTP) = RBD(2:MTP)*(1.0D00 + BESSN(1,IW,2:MTP))*TB(2:MTP)*RPOR(2:& - MTP) + MTP) ! - ENDIF + ENDIF ! - CALL QUAD (RESULT) - RKINT = RESULT + CALL QUAD (RESULT) + RKINT = RESULT ! ! Debug printout if option set ! IF (LDBPR(11)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IC), NH(IC), NP(IB)& - , NH(IB), NP(ID), NH(ID), IW, RESULT + , NH(IB), NP(ID), NH(ID), IW, RESULT ! - RETURN + RETURN ! 300 FORMAT('_ (',1I2,')'/,'R (',1I2,1A2,',',1I2,1A2,'|',1I2,1A2,',',1I2,& - 1A2,';',1I2,') = ',1P,D19.12) - RETURN + 1A2,';',1I2,') = ',1P,D19.12) + RETURN ! - END FUNCTION RKINT + END FUNCTION RKINT diff --git a/src/appl/rci90_mpi/rkint_I.f90 b/src/appl/rci90_mpi/rkint_I.f90 index 13b298338..034da1e9f 100644 --- a/src/appl/rci90_mpi/rkint_I.f90 +++ b/src/appl/rci90_mpi/rkint_I.f90 @@ -1,19 +1,19 @@ - MODULE rkint_I + MODULE rkint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION rkint (RAC, IA, IC, RBD, IB, ID, K, IW) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IW - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IW + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/rkintc.f90 b/src/appl/rci90_mpi/rkintc.f90 index 71ecbd2b8..aef41f846 100644 --- a/src/appl/rci90_mpi/rkintc.f90 +++ b/src/appl/rci90_mpi/rkintc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) + SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) ! * ! k * ! This routine returns R (abcd) integrals. * @@ -8,13 +8,13 @@ SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE cteilsrk_C USE orb_C USE kkstart_C @@ -25,81 +25,81 @@ SUBROUTINE RKINTC(IA, IB, IC, ID, K, TEGRAL) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IA, IB, IC, ID - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(OUT) :: TEGRAL + INTEGER, INTENT(INOUT) :: IA, IB, IC, ID + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(OUT) :: TEGRAL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KEY, ISWAP, INDEX, JL, JU, JM, LOC - LOGICAL :: FOUND, FIRST + INTEGER :: KEY, ISWAP, INDEX, JL, JU, JM, LOC + LOGICAL :: FOUND, FIRST !----------------------------------------------- ! - KEY = NW + 1 + KEY = NW + 1 ! ! Ensure that the indices are in `canonical' order ! Compute the composite (packed) index ! - - - IF (IA > IC) THEN - ISWAP = IC - IC = IA - IA = ISWAP - ENDIF - IF (IB > ID) THEN - ISWAP = ID - ID = IB - IB = ISWAP - ENDIF - IF (IA > IB) THEN - ISWAP = IB - IB = IA - IA = ISWAP - ISWAP = ID - ID = IC - IC = ISWAP - ENDIF - - INDEX = ((IA*KEY + IB)*KEY + IC)*KEY + ID + + + IF (IA > IC) THEN + ISWAP = IC + IC = IA + IA = ISWAP + ENDIF + IF (IB > ID) THEN + ISWAP = ID + ID = IB + IB = ISWAP + ENDIF + IF (IA > IB) THEN + ISWAP = IB + IB = IA + IA = ISWAP + ISWAP = ID + ID = IC + IC = ISWAP + ENDIF + + INDEX = ((IA*KEY + IB)*KEY + IC)*KEY + ID ! - JL = KSTART(K) - JU = KSTART(K+1) - 1 - IF (INDEXINDTEIRK(JU)) THEN - WRITE (*, *) 'Something wrong in rkintc' - STOP - ENDIF + JL = KSTART(K) + JU = KSTART(K+1) - 1 + IF (INDEXINDTEIRK(JU)) THEN + WRITE (*, *) 'Something wrong in rkintc' + STOP + ENDIF ! ! The index is within the range of the indices stored; search ! for it in the list of indices ! - 1 CONTINUE - IF (JU - JL > 1) THEN - JM = (JU + JL)/2 - IF (INDTEIRK(JM) > INDEX) THEN - JU = JM - ELSE - JL = JM - ENDIF - GO TO 1 - ENDIF + 1 CONTINUE + IF (JU - JL > 1) THEN + JM = (JU + JL)/2 + IF (INDTEIRK(JM) > INDEX) THEN + JU = JM + ELSE + JL = JM + ENDIF + GO TO 1 + ENDIF ! ! The range is bracketed to the extent possible ! - IF (INDEX == INDTEIRK(JU)) THEN - LOC = JU - ELSE IF (INDEX == INDTEIRK(JL)) THEN - LOC = JL - ELSE - WRITE (*, *) K, IA, IB, IC, ID, INDEX - WRITE (*, *) 'Rkintc Integral not found' - STOP - ENDIF + IF (INDEX == INDTEIRK(JU)) THEN + LOC = JU + ELSE IF (INDEX == INDTEIRK(JL)) THEN + LOC = JL + ELSE + WRITE (*, *) K, IA, IB, IC, ID, INDEX + WRITE (*, *) 'Rkintc Integral not found' + STOP + ENDIF ! ! Return the value of the integral ! from storage - - TEGRAL = VALTEIRK(LOC) + + TEGRAL = VALTEIRK(LOC) ! - RETURN - END SUBROUTINE RKINTC + RETURN + END SUBROUTINE RKINTC diff --git a/src/appl/rci90_mpi/rkintc_I.f90 b/src/appl/rci90_mpi/rkintc_I.f90 index 6ae6339d3..a0a9bf3c7 100644 --- a/src/appl/rci90_mpi/rkintc_I.f90 +++ b/src/appl/rci90_mpi/rkintc_I.f90 @@ -1,18 +1,18 @@ - MODULE rkintc_I + MODULE rkintc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE rkintc (IA, IB, IC, ID, K, TEGRAL) - USE vast_kind_param,ONLY: DOUBLE -! INTEGER KMAX -! PARAMETER (KMAX = 20) - INTEGER, INTENT(INOUT) :: IA - INTEGER, INTENT(INOUT) :: IB - INTEGER, INTENT(INOUT) :: IC - INTEGER, INTENT(INOUT) :: ID - INTEGER, INTENT(INOUT) :: K - REAL(DOUBLE), INTENT(OUT) :: TEGRAL - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE rkintc (IA, IB, IC, ID, K, TEGRAL) + USE vast_kind_param,ONLY: DOUBLE +! INTEGER KMAX +! PARAMETER (KMAX = 20) + INTEGER, INTENT(INOUT) :: IA + INTEGER, INTENT(INOUT) :: IB + INTEGER, INTENT(INOUT) :: IC + INTEGER, INTENT(INOUT) :: ID + INTEGER, INTENT(INOUT) :: K + REAL(DOUBLE), INTENT(OUT) :: TEGRAL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/setdbg.f90 b/src/appl/rci90_mpi/setdbg.f90 index 2c923b5f0..18f8b2728 100644 --- a/src/appl/rci90_mpi/setdbg.f90 +++ b/src/appl/rci90_mpi/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG + SUBROUTINE SETDBG ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -9,17 +9,17 @@ SUBROUTINE SETDBG ! Written by Farid A Parpia Last update: 21 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- USE debug_C IMPLICIT NONE ! - LDBPA = .FALSE. - LDBPG = .FALSE. - - LDBPR = .FALSE. - - RETURN - END SUBROUTINE SETDBG + LDBPA = .FALSE. + LDBPG = .FALSE. + + LDBPR = .FALSE. + + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rci90_mpi/setdbg_I.f90 b/src/appl/rci90_mpi/setdbg_I.f90 index 5cd21e293..1b7cb7142 100644 --- a/src/appl/rci90_mpi/setdbg_I.f90 +++ b/src/appl/rci90_mpi/setdbg_I.f90 @@ -1,9 +1,9 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setdbg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/setham_gg.f90 b/src/appl/rci90_mpi/setham_gg.f90 index bd6ba5186..55b4621cc 100644 --- a/src/appl/rci90_mpi/setham_gg.f90 +++ b/src/appl/rci90_mpi/setham_gg.f90 @@ -15,8 +15,8 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! Block version by Xinghong He Last revision: 15 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -87,19 +87,19 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & REAL(DOUBLE), DIMENSION(NNNW) :: tshell REAL(DOUBLE) :: tgrl1, tgrl2, tegral - + INTEGER, PARAMETER :: KEY = KEYORB ! ! Matrix elements smaller than CUTOFF are not accumulated ! -!cjb cutoff is use associated and cannot be redeclared +!cjb cutoff is use associated and cannot be redeclared ! REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-20 !cjb CUTOFF = 1.0D-12 below !cjb INTEGER :: ipi, ipj, inc1, inc2, kt, ipt, incor, ncoec, nctec, & i, j, nmcbp, ncore, ic, nelc, irstart, ir, ia, ib, & itype, nctei, iia - REAL(DOUBLE) :: elemnt, precoeff, tcoeff, vcoeff, contr + REAL(DOUBLE) :: elemnt, precoeff, tcoeff, vcoeff, contr !----------------------------------------------------------------------- nelmnt = nelmntt !cjb @@ -107,7 +107,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & CUTOFF = 1.0D-12 ATWINV = 1.D0/EMN - + IF (IPRERUN .EQ. 2) THEN DO IPI = 1,NVEC DO IPJ = 1,NCF @@ -120,7 +120,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! used for the Coulomb and transverse two-electron integrals ! CALL ALCBUF (1) - + ! ...Locals CALL alloc (emt, ncf, 'EMT','SETHAM' ) CALL alloc (irow, ncf, 'IROW', 'SETHAM') @@ -135,13 +135,13 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & IPT = 1 ! INCOR = 1 - + NCOEC = 0 ! NCTEC = 0 - + IF (LTRANS) THEN - + ! ...Initialisations for transverse interaction correction DO 2 I = 1, NW ICORE(I) = 0 @@ -150,30 +150,30 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ENDDO ICORE(I) = 1 2 CONTINUE - + NMCBP = 0 NCORE = 0 ENDIF - + ! Loop over rows of the Hamiltonian matrix - distributed - + DO 10 ic = icstrt, ncf, nprocs - + NELC = 0 ! counter - Number of non-zeros of this row - + ! Loop over columns of the current row - + irstart = 1 DO 85 IR = irstart, IC - + ! PER IF (LFORDR .AND. (IR .GT. ICCUT(1))) THEN IF (IR.NE.IC) CYCLE END IF ! PER - + ELEMNT = 0.D0 ! accumulates various contributions to H - + ! ! Generate the integral list for the matrix element of the ! one-body operators @@ -185,7 +185,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & INC1 = 1 ENDIF ENDIF - + IF (IPRERUN .EQ. 2) THEN ! ! Diagonal elements are always included @@ -207,10 +207,10 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & IF (PRECOEFF .GT. COEFFCUT2) INC2 = 1 ENDDO ENDIF - + ! ...INC1.EQ.1 ------------> IF (INC1 .EQ. 1) THEN !inc1 is always 1 without PRE-RUN - CALL ONESCALAR(IC,IR,IA,IB,TSHELL) + CALL ONESCALAR(IC,IR,IA,IB,TSHELL) ! ! Accumulate the contribution from the one-body operators: ! kinetic energy, electron-nucleus interaction; update the @@ -289,7 +289,7 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & 7 CONTINUE ! IBUG1 = 0 - + ENDIF !inc1 is always 1 without PRE-RUN ! ...INC1.EQ.1 <------------ !*********************************************************************** @@ -446,11 +446,11 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & ! Deallocate storage for the arrays in /BUFFER/ ! CALL ALCBUF (3) - + ! ...Locals CALL DALLOC (EMT, 'EMT', 'SETHAM') CALL DALLOC (IROW, 'IROW', 'SETHAM') - + ! Fill the common block /setham_to_genmat2/ for use in genmat2 CUTOFFtmp = CUTOFF @@ -466,6 +466,6 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & NVINTItmp = NVINTI NELMNTtmp = NELMNT NCFtmp = NCF - + RETURN END SUBROUTINE SETHAM diff --git a/src/appl/rci90_mpi/setham_gg_I.f90 b/src/appl/rci90_mpi/setham_gg_I.f90 index dbb0c22dd..de01501c8 100644 --- a/src/appl/rci90_mpi/setham_gg_I.f90 +++ b/src/appl/rci90_mpi/setham_gg_I.f90 @@ -1,7 +1,7 @@ MODULE setham_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & atwinv,slf_en) @@ -14,4 +14,3 @@ SUBROUTINE SETHAM (myid, nprocs, jblock, ELSTO,ICSTRT, nelmntt, & END SUBROUTINE SETHAM END INTERFACE END MODULE - diff --git a/src/appl/rci90_mpi/setmixmpi.f90 b/src/appl/rci90_mpi/setmixmpi.f90 index 465ae2f55..50c7eff82 100644 --- a/src/appl/rci90_mpi/setmixmpi.f90 +++ b/src/appl/rci90_mpi/setmixmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETMIXmpi(NAME, IDBLK) + SUBROUTINE SETMIXmpi(NAME, IDBLK) ! * ! Opens the .mix file on stream 25; writes a header to this file; * ! calls LODMIX to interactively determine the eigenpairs required. * @@ -12,8 +12,8 @@ SUBROUTINE SETMIXmpi(NAME, IDBLK) ! Modified by Xinghong He Last revision: 23 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! C O M M O N B l o c k s @@ -22,19 +22,19 @@ SUBROUTINE SETMIXmpi(NAME, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodmixmpi_I + USE openfl_I + USE lodmixmpi_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER(LEN=*) , INTENT(IN) :: NAME - CHARACTER(LEN=8), DIMENSION(*) :: IDBLK + CHARACTER(LEN=*) , INTENT(IN) :: NAME + CHARACTER(LEN=8), DIMENSION(*) :: IDBLK !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' - CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' + CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' + CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -49,9 +49,9 @@ SUBROUTINE SETMIXmpi(NAME, IDBLK) ENDIF WRITE (25) 'G92MIX' - ENDIF - - CALL LODMIXmpi (IDBLK) - - RETURN + ENDIF + + CALL LODMIXmpi (IDBLK) + + RETURN END SUBROUTINE SETMIXmpi diff --git a/src/appl/rci90_mpi/setmixmpi_I.f90 b/src/appl/rci90_mpi/setmixmpi_I.f90 index 92eb54fc7..2975004b7 100644 --- a/src/appl/rci90_mpi/setmixmpi_I.f90 +++ b/src/appl/rci90_mpi/setmixmpi_I.f90 @@ -1,11 +1,11 @@ - MODULE setmixmpi_I + MODULE setmixmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmixmpi (NAME, IDBLK) - CHARACTER (LEN = *), INTENT(IN) :: NAME - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmixmpi (NAME, IDBLK) + CHARACTER (LEN = *), INTENT(IN) :: NAME + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/setres.f90 b/src/appl/rci90_mpi/setres.f90 index 3402209b6..b1a6eaa6f 100644 --- a/src/appl/rci90_mpi/setres.f90 +++ b/src/appl/rci90_mpi/setres.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) + SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! * ! Open, check, load data from the .res file. * ! * @@ -10,11 +10,11 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! Modified by Xinghong Last revision: 23 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man USE default_C @@ -26,29 +26,29 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I - USE lodres_I - USE getcid_I + USE getyn_I + USE openfl_I + USE lodres_I + USE getcid_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: ISOFILE*(*) - CHARACTER :: RWFFILE*(*) + CHARACTER :: ISOFILE*(*) + CHARACTER :: RWFFILE*(*) CHARACTER(LEN=8), DIMENSION(*) :: IDBLK !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' - CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' - CHARACTER*6, PARAMETER :: RESTITLE = 'R92RES' + CHARACTER*11, PARAMETER :: FORM = 'UNFORMATTED' + CHARACTER*7, PARAMETER :: STATUS = 'UNKNOWN' + CHARACTER*6, PARAMETER :: RESTITLE = 'R92RES' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IOS - LOGICAL :: FOUND, RESTRT - CHARACTER :: R92RES*6, DEFNAM*11, IDSTRING*3 + INTEGER :: IOS + LOGICAL :: FOUND, RESTRT + CHARACTER :: R92RES*6, DEFNAM*11, IDSTRING*3 !----------------------------------------------- ! ! Compose the "rciXXX.res" file names (for each node) @@ -59,12 +59,12 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! Ask if this is a restart ! IF (myid .EQ. 0) THEN - IF (NDEF /= 0) THEN - WRITE (ISTDE, *) 'Restarting RCI90 ?' - RESTRT = GETYN() - ELSE - RESTRT = .FALSE. - ENDIF + IF (NDEF /= 0) THEN + WRITE (ISTDE, *) 'Restarting RCI90 ?' + RESTRT = GETYN() + ELSE + RESTRT = .FALSE. + ENDIF ! IF (RESTRT) THEN ! WRITE(734,'(a)') 'y ! Restarting RCI90 ?' ! ELSE @@ -75,17 +75,17 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! ! Do some settings and checks ! - IF (RESTRT) THEN + IF (RESTRT) THEN ! ...Restart, make sure file exist - INQUIRE(FILE=DEFNAM, EXIST=FOUND) + INQUIRE(FILE=DEFNAM, EXIST=FOUND) IF (.NOT. FOUND) THEN CALL stopmpi ('setres: .res not exist', myid) ENDIF - ENDIF + ENDIF ! ! Open the .res file ! - CALL OPENFL (IMCDF, DEFNAM, FORM, STATUS, IERR) + CALL OPENFL (IMCDF, DEFNAM, FORM, STATUS, IERR) IF (IERR .NE. 0) THEN CALL stopmpi ('setres: Error openning .res file', myid) ENDIF @@ -94,27 +94,27 @@ SUBROUTINE SETRES(ISOFILE, RWFFILE, IDBLK) ! ! But first of all, iccutblk() is needed in both cases ! - CALL ALLOC (ICCUTBLK, NBLOCK, 'ICCUTBLK', 'SETRES') - - IF (RESTRT) THEN + CALL ALLOC (ICCUTBLK, NBLOCK, 'ICCUTBLK', 'SETRES') + + IF (RESTRT) THEN ! ...Check the signature of the file - READ (IMCDF, IOSTAT=IOS) R92RES - IF (IOS/=0 .OR. R92RES/=RESTITLE) THEN - CLOSE(IMCDF) + READ (IMCDF, IOSTAT=IOS) R92RES + IF (IOS/=0 .OR. R92RES/=RESTITLE) THEN + CLOSE(IMCDF) CALL stopmpi ('setres: Not RCI92 .res file', myid) - ENDIF - + ENDIF + ! ...Read and check restart information - CALL LODRES - - ELSE - + CALL LODRES + + ELSE + ! ...Write the file header ! ...Generate the first part of the .res file - WRITE (IMCDF) RESTITLE - CALL GETCID (ISOFILE, RWFFILE, IDBLK) - - ENDIF - - RETURN - END SUBROUTINE SETRES + WRITE (IMCDF) RESTITLE + CALL GETCID (ISOFILE, RWFFILE, IDBLK) + + ENDIF + + RETURN + END SUBROUTINE SETRES diff --git a/src/appl/rci90_mpi/setres_I.f90 b/src/appl/rci90_mpi/setres_I.f90 index 905dcc83c..3ac43ede3 100644 --- a/src/appl/rci90_mpi/setres_I.f90 +++ b/src/appl/rci90_mpi/setres_I.f90 @@ -1,12 +1,12 @@ - MODULE setres_I + MODULE setres_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setres (ISOFILE, RWFFILE, IDBLK) - CHARACTER (LEN = *) :: ISOFILE - CHARACTER (LEN = *) :: RWFFILE - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setres (ISOFILE, RWFFILE, IDBLK) + CHARACTER (LEN = *) :: ISOFILE + CHARACTER (LEN = *) :: RWFFILE + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/setsum.f90 b/src/appl/rci90_mpi/setsum.f90 index 56c586a47..d30ab9bf7 100644 --- a/src/appl/rci90_mpi/setsum.f90 +++ b/src/appl/rci90_mpi/setsum.f90 @@ -1,32 +1,32 @@ !*********************************************************************** - - SUBROUTINE SETSUM(NAME) + + SUBROUTINE SETSUM(NAME) ! ! Open the .csum file on stream 24. ! Xinghong He 10 Jun 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER(LEN=*) , INTENT(IN) :: NAME + CHARACTER(LEN=*) , INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR + INTEGER :: K, IERR !----------------------------------------------------------------------- - - K = INDEX(NAME,' ') - - CALL OPENFL (24, NAME(1:K-1)//'.csum', 'FORMATTED', 'UNKNOWN', IERR) - - RETURN - END SUBROUTINE SETSUM + + K = INDEX(NAME,' ') + + CALL OPENFL (24, NAME(1:K-1)//'.csum', 'FORMATTED', 'UNKNOWN', IERR) + + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rci90_mpi/setsum_I.f90 b/src/appl/rci90_mpi/setsum_I.f90 index a80e1be1c..e980ab956 100644 --- a/src/appl/rci90_mpi/setsum_I.f90 +++ b/src/appl/rci90_mpi/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (NAME) - CHARACTER (LEN = *), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (NAME) + CHARACTER (LEN = *), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/skint.f90 b/src/appl/rci90_mpi/skint.f90 index dfba2b7d9..2096705f9 100644 --- a/src/appl/rci90_mpi/skint.f90 +++ b/src/appl/rci90_mpi/skint.f90 @@ -14,13 +14,13 @@ REAL(KIND(0.0D0)) FUNCTION SKINT (RAC, IA, IC, RBD, IB, ID, K, IW) ! Last update: 06 Nov 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE bess_C USE debug_C @@ -31,86 +31,86 @@ REAL(KIND(0.0D0)) FUNCTION SKINT (RAC, IA, IC, RBD, IB, ID, K, IW) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE zkf_I - USE quad_I + USE zkf_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IA, IB, IC, ID - INTEGER, INTENT(IN) :: K, IW + INTEGER :: IA, IB, IC, ID + INTEGER, INTENT(IN) :: K, IW REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXRAC, MXRBD, I - REAL(DOUBLE), DIMENSION(NNNP) :: TKEEP - REAL(DOUBLE) :: EPSI, W, WK, VALU + INTEGER :: MXRAC, MXRBD, I + REAL(DOUBLE), DIMENSION(NNNP) :: TKEEP + REAL(DOUBLE) :: EPSI, W, WK, VALU !----------------------------------------------- ! ! - EPSI = 1.0D-10 + EPSI = 1.0D-10 ! - W = WIJ(IW) - WK = DBLE(K + K + 1) - MXRAC = MIN(MF(IA),MF(IC)) - MXRBD = MIN(MF(IB),MF(ID)) + W = WIJ(IW) + WK = DBLE(K + K + 1) + MXRAC = MIN(MF(IA),MF(IC)) + MXRBD = MIN(MF(IB),MF(ID)) ! ! (k-1) ! Compute Z (rho ; s) ! ac ! - TA(:MXRAC) = RAC(:MXRAC) - MTP = MXRAC - CALL ZKF (K - 1, IA, IC) + TA(:MXRAC) = RAC(:MXRAC) + MTP = MXRAC + CALL ZKF (K - 1, IA, IC) ! - IF (DABS(W) < EPSI) THEN + IF (DABS(W) < EPSI) THEN ! ! W = 0 case ! - TKEEP(:MTP) = TB(:MTP) - CALL ZKF (K + 1, IA, IC) - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 - TA(2:MTP) = RBD(2:MTP)*RPOR(2:MTP)*(TB(2:MTP)-TKEEP(2:MTP)) - CALL QUAD (VALU) - SKINT = WK*VALU*0.5D00 + TKEEP(:MTP) = TB(:MTP) + CALL ZKF (K + 1, IA, IC) + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 + TA(2:MTP) = RBD(2:MTP)*RPOR(2:MTP)*(TB(2:MTP)-TKEEP(2:MTP)) + CALL QUAD (VALU) + SKINT = WK*VALU*0.5D00 ! - ELSE + ELSE ! ! Finite w: see I P Grant and B J McKenzie, J Phys B: At Mol Phys, ! 13 (1980) 2671-2681 ! - TKEEP(:MTP) = TB(:MTP) - TA(:MTP) = -TA(:MTP)*BESSJ(1,IW,:MTP) - CALL ZKF (K - 1, IA, IC) + TKEEP(:MTP) = TB(:MTP) + TA(:MTP) = -TA(:MTP)*BESSJ(1,IW,:MTP) + CALL ZKF (K - 1, IA, IC) ! - MTP = MIN(MTP,MXRBD) - TA(1) = 0.0D00 + MTP = MIN(MTP,MXRBD) + TA(1) = 0.0D00 TA(2:MTP) = ((1.0D00 + BESSN(2,IW,2:MTP))*TB(2:MTP)-TKEEP(2:MTP)*BESSN& - (2,IW,2:MTP))*RBD(2:MTP)/R(2:MTP)**2*RPOR(2:MTP) - CALL QUAD (VALU) - SKINT = (WK/W)**2*VALU - TA(:MXRBD) = RBD(:MXRBD)*(1.0D00 + BESSJ(2,IW,:MXRBD)) - MTP = MXRBD - CALL ZKF (K + 1, IB, ID) - MTP = MIN(MTP,MXRAC) - TA(1) = 0.0D00 + (2,IW,2:MTP))*RBD(2:MTP)/R(2:MTP)**2*RPOR(2:MTP) + CALL QUAD (VALU) + SKINT = (WK/W)**2*VALU + TA(:MXRBD) = RBD(:MXRBD)*(1.0D00 + BESSJ(2,IW,:MXRBD)) + MTP = MXRBD + CALL ZKF (K + 1, IB, ID) + MTP = MIN(MTP,MXRAC) + TA(1) = 0.0D00 TA(2:MTP) = RAC(2:MTP)*(1.0D00 + BESSN(1,IW,2:MTP))*TB(2:MTP)*R(2:MTP)& - *RP(2:MTP) - CALL QUAD (VALU) - SKINT = SKINT - VALU*W*W/DBLE((2*K + 3)*(2*K - 1)) + *RP(2:MTP) + CALL QUAD (VALU) + SKINT = SKINT - VALU*W*W/DBLE((2*K + 3)*(2*K - 1)) ! - ENDIF + ENDIF ! IF (LDBPR(11)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IC), NH(IC), NP(IB)& - , NH(IB), NP(ID), NH(ID), IW, VALU + , NH(IB), NP(ID), NH(ID), IW, VALU ! - RETURN + RETURN ! 300 FORMAT(' (',1I2,')'/,'S (',1I2,1A2,',',1I2,1A2,'|',1I2,1A2,',',1I2,& - 1A2,';',1I2,') = ',1P,D19.12) - RETURN + 1A2,';',1I2,') = ',1P,D19.12) + RETURN ! - END FUNCTION SKINT + END FUNCTION SKINT diff --git a/src/appl/rci90_mpi/skint_I.f90 b/src/appl/rci90_mpi/skint_I.f90 index 9449ba232..67c5d0462 100644 --- a/src/appl/rci90_mpi/skint_I.f90 +++ b/src/appl/rci90_mpi/skint_I.f90 @@ -1,19 +1,19 @@ - MODULE skint_I + MODULE skint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION skint (RAC, IA, IC, RBD, IB, ID, K, IW) - USE vast_kind_param,ONLY: DOUBLE + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IC - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IW - END FUNCTION - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RAC + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IC + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: RBD + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IW + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/snrc.f90 b/src/appl/rci90_mpi/snrc.f90 index e4734806b..d15dd3d95 100644 --- a/src/appl/rci90_mpi/snrc.f90 +++ b/src/appl/rci90_mpi/snrc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) ! * ! Determines the range of tensor rank NU for direct/exchange terms, * ! and classifies the types of radial integral. * @@ -22,98 +22,98 @@ SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: ND1 - INTEGER, INTENT(OUT) :: ND2 - INTEGER, INTENT(OUT) :: NE1 - INTEGER, INTENT(OUT) :: NE2 - INTEGER, INTENT(OUT) :: IBRD - INTEGER, INTENT(OUT) :: IBRE - INTEGER, INTENT(IN) :: IS(4) - INTEGER, INTENT(IN) :: KAPS(4) - INTEGER, INTENT(IN) :: KS(4) + INTEGER, INTENT(OUT) :: ND1 + INTEGER, INTENT(OUT) :: ND2 + INTEGER, INTENT(OUT) :: NE1 + INTEGER, INTENT(OUT) :: NE2 + INTEGER, INTENT(OUT) :: IBRD + INTEGER, INTENT(OUT) :: IBRE + INTEGER, INTENT(IN) :: IS(4) + INTEGER, INTENT(IN) :: KAPS(4) + INTEGER, INTENT(IN) :: KS(4) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IAC, IAD, ND1A, ND2A, NE1A, NE2A + INTEGER :: IAC, IAD, ND1A, ND2A, NE1A, NE2A !----------------------------------------------- ! - ND2 = 0 - NE2 = 0 + ND2 = 0 + NE2 = 0 ! ! 2.0 Form limits for direct terms ! - IAC = 1 - IF (KAPS(1)*KAPS(3) < 0) IAC = -1 - IAD = 1 - IF (KAPS(2)*KAPS(4) < 0) IAD = -1 - ND1 = ABS(KS(1)-KS(3))/2 - 1 - IF (IAC == (-1)) ND1 = ND1 + 1 - IF (ND1 == (-1)) ND1 = 1 - ND1A = ABS(KS(2)-KS(4))/2 - 1 - IF (IAD == (-1)) ND1A = ND1A + 1 - IF (ND1A == (-1)) ND1A = 1 - IF (MOD(ND1 - ND1A,2) /= 0) THEN - IBRD = -1 - ELSE - ND2 = ABS(KS(1)+KS(3))/2 - IF (IAC == (-1)) ND2 = ND2 + 1 - ND2A = ABS(KS(2)+KS(4))/2 - IF (IAD == (-1)) ND2A = ND2A + 1 - ND1 = MAX(ND1,ND1A) - ND2 = MIN(ND2,ND2A) - ND2 = (ND2 - ND1)/2 + 1 + IAC = 1 + IF (KAPS(1)*KAPS(3) < 0) IAC = -1 + IAD = 1 + IF (KAPS(2)*KAPS(4) < 0) IAD = -1 + ND1 = ABS(KS(1)-KS(3))/2 - 1 + IF (IAC == (-1)) ND1 = ND1 + 1 + IF (ND1 == (-1)) ND1 = 1 + ND1A = ABS(KS(2)-KS(4))/2 - 1 + IF (IAD == (-1)) ND1A = ND1A + 1 + IF (ND1A == (-1)) ND1A = 1 + IF (MOD(ND1 - ND1A,2) /= 0) THEN + IBRD = -1 + ELSE + ND2 = ABS(KS(1)+KS(3))/2 + IF (IAC == (-1)) ND2 = ND2 + 1 + ND2A = ABS(KS(2)+KS(4))/2 + IF (IAD == (-1)) ND2A = ND2A + 1 + ND1 = MAX(ND1,ND1A) + ND2 = MIN(ND2,ND2A) + ND2 = (ND2 - ND1)/2 + 1 ! ! 2.1 Identify type of radial integrals ! - IBRD = 1 + IBRD = 1 IF (IS(1)==IS(3) .AND. IS(2)/=IS(4) .OR. IS(1)/=IS(3) .AND. IS(2)==IS(& - 4)) IBRD = 2 - IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRD = 3 - ENDIF + 4)) IBRD = 2 + IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRD = 3 + ENDIF ! ! 3.0 Form limits for exchange terms ! - IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) THEN - IBRE = -1 - RETURN - ENDIF - IAC = 1 - IF (KAPS(1)*KAPS(4) < 0) IAC = -1 - IAD = 1 - IF (KAPS(2)*KAPS(3) < 0) IAD = -1 - NE1 = IABS(KS(1)-KS(4))/2 - 1 - IF (IAC == (-1)) NE1 = NE1 + 1 - IF (NE1 == (-1)) NE1 = 1 - NE1A = ABS(KS(2)-KS(3))/2 - 1 - IF (IAD == (-1)) NE1A = NE1A + 1 - IF (NE1A == (-1)) NE1A = 1 - IF (MOD(NE1 - NE1A,2) /= 0) THEN - IBRE = -1 - RETURN - ENDIF + IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) THEN + IBRE = -1 + RETURN + ENDIF + IAC = 1 + IF (KAPS(1)*KAPS(4) < 0) IAC = -1 + IAD = 1 + IF (KAPS(2)*KAPS(3) < 0) IAD = -1 + NE1 = IABS(KS(1)-KS(4))/2 - 1 + IF (IAC == (-1)) NE1 = NE1 + 1 + IF (NE1 == (-1)) NE1 = 1 + NE1A = ABS(KS(2)-KS(3))/2 - 1 + IF (IAD == (-1)) NE1A = NE1A + 1 + IF (NE1A == (-1)) NE1A = 1 + IF (MOD(NE1 - NE1A,2) /= 0) THEN + IBRE = -1 + RETURN + ENDIF ! - NE2 = ABS(KS(1)+KS(4))/2 - IF (IAC == (-1)) NE2 = NE2 + 1 - NE2A = ABS(KS(2)+KS(3))/2 - IF (IAD == (-1)) NE2A = NE2A + 1 - NE1 = MAX(NE1,NE1A) - NE2 = MIN(NE2,NE2A) - NE2 = (NE2 - NE1)/2 + 1 + NE2 = ABS(KS(1)+KS(4))/2 + IF (IAC == (-1)) NE2 = NE2 + 1 + NE2A = ABS(KS(2)+KS(3))/2 + IF (IAD == (-1)) NE2A = NE2A + 1 + NE1 = MAX(NE1,NE1A) + NE2 = MIN(NE2,NE2A) + NE2 = (NE2 - NE1)/2 + 1 ! ! 3.1 Identify type of radial integrals ! - IBRE = 1 + IBRE = 1 IF (IS(1)==IS(4) .AND. IS(2)/=IS(3) .OR. IS(1)/=IS(4) .AND. IS(2)==IS(3)& - ) IBRE = 2 - IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRE = 4 - RETURN + ) IBRE = 2 + IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRE = 4 + RETURN ! - END SUBROUTINE SNRC + END SUBROUTINE SNRC diff --git a/src/appl/rci90_mpi/snrc_I.f90 b/src/appl/rci90_mpi/snrc_I.f90 index a81879dae..c1ea15e2e 100644 --- a/src/appl/rci90_mpi/snrc_I.f90 +++ b/src/appl/rci90_mpi/snrc_I.f90 @@ -1,18 +1,18 @@ - MODULE snrc_I + MODULE snrc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE snrc (IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, DIMENSION(4), INTENT(IN) :: KS - INTEGER, INTENT(OUT) :: ND1 - INTEGER, INTENT(OUT) :: ND2 - INTEGER, INTENT(OUT) :: NE1 - INTEGER, INTENT(OUT) :: NE2 - INTEGER, INTENT(OUT) :: IBRD - INTEGER, INTENT(OUT) :: IBRE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE snrc (IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, DIMENSION(4), INTENT(IN) :: KS + INTEGER, INTENT(OUT) :: ND1 + INTEGER, INTENT(OUT) :: ND2 + INTEGER, INTENT(OUT) :: NE1 + INTEGER, INTENT(OUT) :: NE2 + INTEGER, INTENT(OUT) :: IBRD + INTEGER, INTENT(OUT) :: IBRE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/spodmv.f90 b/src/appl/rci90_mpi/spodmv.f90 index 3ee8dcb65..9d2f9cae6 100644 --- a/src/appl/rci90_mpi/spodmv.f90 +++ b/src/appl/rci90_mpi/spodmv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SPODMV(N, M, B, C) + SUBROUTINE SPODMV(N, M, B, C) ! * ! Matrix-matrix product: C = AB. A sparse representation of the * ! lower triangle of the (NxN) matrix A is read from the disk * @@ -15,13 +15,13 @@ SUBROUTINE SPODMV(N, M, B, C) ! Block Version by Xinghong He Last revision: 18 Jun 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE eigv_C USE Where_C USE fposition_C @@ -29,59 +29,59 @@ SUBROUTINE SPODMV(N, M, B, C) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dinit_I - USE posfile_I - USE dmerge_I + USE dinit_I + USE posfile_I + USE dmerge_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(N) :: IROW + INTEGER, DIMENSION(N) :: IROW !cjb INTEGER :: MYID, NPROCS, NCF, NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM, ICOL& INTEGER :: NCF, NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM, ICOL& - , NELC, IR, IV - REAL(DOUBLE), DIMENSION(N) :: EMT - REAL(DOUBLE) :: ELSTO, DIAG, DL + , NELC, IR, IV + REAL(DOUBLE), DIMENSION(N) :: EMT + REAL(DOUBLE) :: ELSTO, DIAG, DL !----------------------------------------------- ! ! !...nposition+1 is the current position of the .res file ! !...It is set in matrix and used in maneig, spodmv ! !----------------------------------------------------------------------- - WRITE (6, *) 'Calling spodmv...' - NCF = N - + WRITE (6, *) 'Calling spodmv...' + NCF = N + ! Initialise the result matrix; note that this is specific to the ! data structure of DVDSON - - CALL DINIT (N*M, 0.D0, C, 1) - + + CALL DINIT (N*M, 0.D0, C, 1) + !...moved from maneig before "CALL GDVD (SPODMV..." - CALL POSFILE (0, IMCDF, NPOSITION) - - READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM + CALL POSFILE (0, IMCDF, NPOSITION) + + READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP & - 'spodmv: ncf read wrong' - - - DO ICOL = MYID + 1, N, NPROCS - READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) - DO IV = 1, M - DIAG = C(ICOL,IV) + (EMT(NELC)-EAV)*B(ICOL,IV) + 'spodmv: ncf read wrong' + + + DO ICOL = MYID + 1, N, NPROCS + READ (IMCDF) NELC, ELSTO, (EMT(IR),IR=1,NELC), (IROW(IR),IR=1,NELC) + DO IV = 1, M + DIAG = C(ICOL,IV) + (EMT(NELC)-EAV)*B(ICOL,IV) CALL DMERGE (NELC - 1, B(1:N,IV), C(1:N,IV), IROW(1:N), & - EMT(1:N), B(ICOL,IV), DL) - C(ICOL,IV) = DIAG + DL - END DO - END DO + EMT(1:N), B(ICOL,IV), DL) + C(ICOL,IV) = DIAG + DL + END DO + END DO + + CALL gdsummpi (C, N*M) - CALL gdsummpi (C, N*M) - - RETURN - END SUBROUTINE SPODMV + RETURN + END SUBROUTINE SPODMV diff --git a/src/appl/rci90_mpi/spodmv_I.f90 b/src/appl/rci90_mpi/spodmv_I.f90 index 787a7d862..af9f606a6 100644 --- a/src/appl/rci90_mpi/spodmv_I.f90 +++ b/src/appl/rci90_mpi/spodmv_I.f90 @@ -1,14 +1,14 @@ - MODULE spodmv_I + MODULE spodmv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spodmv (N, M, B, C) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE spodmv (N, M, B, C) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/strsum.f90 b/src/appl/rci90_mpi/strsum.f90 index 5d122d072..8817c4933 100644 --- a/src/appl/rci90_mpi/strsum.f90 +++ b/src/appl/rci90_mpi/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * ! Generates the first part of grasp92.sum (on stream 24). * ! * @@ -10,13 +10,13 @@ SUBROUTINE STRSUM ! Modified by Xinghong He Last revision: 22 Dec 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE Use decide_C USE def_C USE grid_C @@ -32,112 +32,112 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt2_I + USE convrt2_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: LENTH, NB, ICCUT, I, NTMP - CHARACTER :: RECORD*256, CDATA*26, CLEVEL*2 + CHARACTER :: RECORD*256, CDATA*26, CLEVEL*2 !----------------------------------------------- ! POINTER (pncfblk, ncfblk(0:*)) ! ! POINTER (piccutblk, iccutblk(1)) - + ! ! Get the date and time of day; make this information the ! header of the summary file ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT2 (NELEC, RECORD, LENTH, 'strsum.nelec') - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT2 (NCF, RECORD, LENTH, 'strsum.ncf') - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT2 (NW, RECORD, LENTH, 'strsum.nw') - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT2 (NELEC, RECORD, LENTH, 'strsum.nelec') + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT2 (NCF, RECORD, LENTH, 'strsum.ncf') + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT2 (NW, RECORD, LENTH, 'strsum.nw') + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (LFORDR) THEN - WRITE (24, *) - DO NB = 1, NBLOCK - ICCUT = ICCUTBLK(NB) - CALL CONVRT2 (ICCUT, RECORD, LENTH, 'strsum.icccut') + IF (LFORDR) THEN + WRITE (24, *) + DO NB = 1, NBLOCK + ICCUT = ICCUTBLK(NB) + CALL CONVRT2 (ICCUT, RECORD, LENTH, 'strsum.icccut') WRITE (24, *) ' CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space; nb = ', NB, ' ncf = ', NCFBLK(NB) - END DO - ENDIF + ' the zero-order space; nb = ', NB, ' ncf = ', NCFBLK(NB) + END DO + ENDIF ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z - IF (EMN == 0.0D00) THEN - WRITE (24, *) ' the nucleus is stationary;' - ELSE - WRITE (24, 301) EMN - ENDIF - IF (NPARM == 2) THEN - WRITE (24, *) ' Fermi nucleus:' - WRITE (24, 302) PARM(1), PARM(2) - CALL CONVRT2 (NNUC, RECORD, LENTH, 'strsum.nnuc') + WRITE (24, *) + WRITE (24, 300) Z + IF (EMN == 0.0D00) THEN + WRITE (24, *) ' the nucleus is stationary;' + ELSE + WRITE (24, 301) EMN + ENDIF + IF (NPARM == 2) THEN + WRITE (24, *) ' Fermi nucleus:' + WRITE (24, 302) PARM(1), PARM(2) + CALL CONVRT2 (NNUC, RECORD, LENTH, 'strsum.nnuc') WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 303) C -! - WRITE (24, *) - IF (LTRANS .OR. LVP .OR. LNMS .OR. LSMS) THEN - WRITE (24, *) 'To H (Dirac Coulomb) is added' - IF (LTRANS) WRITE (24, 304) WFACT - IF (LVP) WRITE (24, *) ' H (Vacuum Polarisation);' - IF (LNMS) WRITE (24, *) ' H (Normal Mass Shift);' - IF (LSMS) WRITE (24, *) ' H (Specific Mass Shift);' - WRITE (24, *) ' the total will be diagonalised.' - ELSE - WRITE (24, *) 'H (Dirac Coulomb) will be diagonalised by itself.' - ENDIF -! - IF (LSE) THEN + WRITE (24, *) + WRITE (24, 303) C +! + WRITE (24, *) + IF (LTRANS .OR. LVP .OR. LNMS .OR. LSMS) THEN + WRITE (24, *) 'To H (Dirac Coulomb) is added' + IF (LTRANS) WRITE (24, 304) WFACT + IF (LVP) WRITE (24, *) ' H (Vacuum Polarisation);' + IF (LNMS) WRITE (24, *) ' H (Normal Mass Shift);' + IF (LSMS) WRITE (24, *) ' H (Specific Mass Shift);' + WRITE (24, *) ' the total will be diagonalised.' + ELSE + WRITE (24, *) 'H (Dirac Coulomb) will be diagonalised by itself.' + ENDIF +! + IF (LSE) THEN WRITE (24, *) & - 'Diagonal contributions from H (Self Energy) will be estimated' - WRITE (24, *) ' from a screened hydrogenic approximation.' - ENDIF + 'Diagonal contributions from H (Self Energy) will be estimated' + WRITE (24, *) ' from a screened hydrogenic approximation.' + ENDIF ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.0D00) THEN - WRITE (24, 305) RNT, H, N - ELSE - WRITE (24, 306) RNT, H, HP, N - ENDIF - WRITE (24, 307) R(1), R(2), R(N) + WRITE (24, *) + IF (HP == 0.0D00) THEN + WRITE (24, 305) RNT, H, N + ELSE + WRITE (24, 306) RNT, H, HP, N + ENDIF + WRITE (24, 307) R(1), R(2), R(N) ! ! Write out the orbital properties ! - WRITE (24, *) - WRITE (24, *) 'Subshell radial wavefunction summary:' - WRITE (24, *) - WRITE (24, 308) - WRITE (24, *) - DO I = 1, NW + WRITE (24, *) + WRITE (24, *) 'Subshell radial wavefunction summary:' + WRITE (24, *) + WRITE (24, 308) + WRITE (24, *) + DO I = 1, NW WRITE (24, 309) NP(I), NH(I), E(I), PZ(I), GAMA(I), PF(2,I), QF(2,I), & - MF(I) - END DO + MF(I) + END DO ! ! Write the list of eigenpair indices ! - WRITE (24, *) + WRITE (24, *) ! ! Find total number of eigenstates and print corresponding info ! @@ -148,26 +148,26 @@ SUBROUTINE STRSUM WRITE (24,*) ntmp, ' levels will be computed' - RETURN + RETURN ! - 300 FORMAT('The atomic number is ',1F14.10,';') - 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') - 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') + 300 FORMAT('The atomic number is ',1F14.10,';') + 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') + 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') 304 FORMAT(' H (Transverse) --- factor multiplying the',& - ' photon frequency: ',1P,D15.8,';') + ' photon frequency: ',1P,D15.8,';') 305 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 306 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 307 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') 308 FORMAT('Subshell',6X,'e',13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',4X,'MTP'& - ) - 309 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,2(D11.3),I5) - RETURN + ) + 309 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,2(D11.3),I5) + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rci90_mpi/strsum_I.f90 b/src/appl/rci90_mpi/strsum_I.f90 index a05210712..634f32b9f 100644 --- a/src/appl/rci90_mpi/strsum_I.f90 +++ b/src/appl/rci90_mpi/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/talk.f90 b/src/appl/rci90_mpi/talk.f90 index 3a1c24ec8..1cae89a22 100644 --- a/src/appl/rci90_mpi/talk.f90 +++ b/src/appl/rci90_mpi/talk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! * ! Print coefficients and integral parameters if IBUG1 > 0 and * ! write to disk. * @@ -8,61 +8,61 @@ SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB - USE BUFFER_C + USE BUFFER_C USE debug_C USE orb_C USE cons_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcbuf_I + USE alcbuf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF + INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! Print coefficient if requested ! IF (IBUG1 /= 0) WRITE (99, 300)JA,JB,NP(IA),NH(IA),NP(IB),NH(IB),& - NP(IC),NH(IC),NP(ID),NH(ID),NU,ITYPE,COEF + NP(IC),NH(IC),NP(ID),NH(ID),NU,ITYPE,COEF ! ! Increment counter ! IF(DABS(COEF) > EPS) THEN - NVCOEF = NVCOEF + 1 + NVCOEF = NVCOEF + 1 ! ! Ensure that arrays are of adequate size; reallocate if necessary ! - IF (NVCOEF > NBDIM) CALL ALCBUF (2) + IF (NVCOEF > NBDIM) CALL ALCBUF (2) ! ! Store integral indices and coefficient in COMMON/BUFFER/ ! - LABEL(1,NVCOEF) = IA - LABEL(2,NVCOEF) = IB - LABEL(3,NVCOEF) = IC - LABEL(4,NVCOEF) = ID - LABEL(5,NVCOEF) = NU - LABEL(6,NVCOEF) = ITYPE - COEFF(NVCOEF) = COEF + LABEL(1,NVCOEF) = IA + LABEL(2,NVCOEF) = IB + LABEL(3,NVCOEF) = IC + LABEL(4,NVCOEF) = ID + LABEL(5,NVCOEF) = NU + LABEL(6,NVCOEF) = ITYPE + COEFF(NVCOEF) = COEF END IF ! - RETURN + RETURN ! - 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) - RETURN + 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) + RETURN ! - END SUBROUTINE TALK + END SUBROUTINE TALK diff --git a/src/appl/rci90_mpi/talk_I.f90 b/src/appl/rci90_mpi/talk_I.f90 index e8373cb48..fd323fa75 100644 --- a/src/appl/rci90_mpi/talk_I.f90 +++ b/src/appl/rci90_mpi/talk_I.f90 @@ -1,19 +1,19 @@ - MODULE talk_I + MODULE talk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/triangbreit1.f90 b/src/appl/rci90_mpi/triangbreit1.f90 index bbfa29715..e62c147ca 100644 --- a/src/appl/rci90_mpi/triangbreit1.f90 +++ b/src/appl/rci90_mpi/triangbreit1.f90 @@ -9,12 +9,12 @@ LOGICAL FUNCTION TRIANGBREIT1 (IA,IB,IC,ID,K) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s !----------------------------------------------- - USE orb_C, ONLY: NKL, NKJ + USE orb_C, ONLY: NKL, NKJ IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s diff --git a/src/appl/rci90_mpi/triangbreit1_I.f90 b/src/appl/rci90_mpi/triangbreit1_I.f90 index 69f7ad97d..691b7cb61 100644 --- a/src/appl/rci90_mpi/triangbreit1_I.f90 +++ b/src/appl/rci90_mpi/triangbreit1_I.f90 @@ -1,9 +1,9 @@ - MODULE TRIANGBREIT1_I + MODULE TRIANGBREIT1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 LOGICAL FUNCTION TRIANGBREIT1 (IA,IB,IC,ID,K) INTEGER, INTENT(IN) :: IA,IB,IC,ID,K - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/triangbreit2.f90 b/src/appl/rci90_mpi/triangbreit2.f90 index a1223136c..846383a2f 100644 --- a/src/appl/rci90_mpi/triangbreit2.f90 +++ b/src/appl/rci90_mpi/triangbreit2.f90 @@ -8,7 +8,7 @@ LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -47,4 +47,3 @@ LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) RETURN END FUNCTION TRIANGBREIT2 - diff --git a/src/appl/rci90_mpi/triangbreit2_I.f90 b/src/appl/rci90_mpi/triangbreit2_I.f90 index db25eba9f..ce4be2a13 100644 --- a/src/appl/rci90_mpi/triangbreit2_I.f90 +++ b/src/appl/rci90_mpi/triangbreit2_I.f90 @@ -1,9 +1,9 @@ - MODULE TRIANGBREIT2_I + MODULE TRIANGBREIT2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 LOGICAL FUNCTION TRIANGBREIT2 (IA,IB,IC,ID,L) INTEGER, INTENT(IN) :: IA,IB,IC,ID,L - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/triangrk.f90 b/src/appl/rci90_mpi/triangrk.f90 index 683fff42b..f66e6ff49 100644 --- a/src/appl/rci90_mpi/triangrk.f90 +++ b/src/appl/rci90_mpi/triangrk.f90 @@ -1,40 +1,40 @@ !*********************************************************************** ! * - LOGICAL FUNCTION TRIANGRK (LA, K, LB) + LOGICAL FUNCTION TRIANGRK (LA, K, LB) ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: LA - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: LB + INTEGER, INTENT(IN) :: LA + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: LB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! Perform the triangularity check ! - IF (MOD(K + LA + LB,2) /= 0) THEN - TRIANGRK = .FALSE. - ELSE - IF (ABS(LA - LB) > K) THEN - TRIANGRK = .FALSE. - ELSE IF (LA + LB < K) THEN - TRIANGRK = .FALSE. - ELSE - TRIANGRK = .TRUE. - ENDIF - ENDIF - - RETURN - END FUNCTION TRIANGRK + IF (MOD(K + LA + LB,2) /= 0) THEN + TRIANGRK = .FALSE. + ELSE + IF (ABS(LA - LB) > K) THEN + TRIANGRK = .FALSE. + ELSE IF (LA + LB < K) THEN + TRIANGRK = .FALSE. + ELSE + TRIANGRK = .TRUE. + ENDIF + ENDIF + + RETURN + END FUNCTION TRIANGRK diff --git a/src/appl/rci90_mpi/triangrk_I.f90 b/src/appl/rci90_mpi/triangrk_I.f90 index bb81955e6..105bd4f09 100644 --- a/src/appl/rci90_mpi/triangrk_I.f90 +++ b/src/appl/rci90_mpi/triangrk_I.f90 @@ -1,12 +1,12 @@ - MODULE triangrk_I + MODULE triangrk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL FUNCTION triangrk (LA, K, LB) - INTEGER, INTENT(IN) :: LA - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: LB - END FUNCTION - END INTERFACE - END MODULE + LOGICAL FUNCTION triangrk (LA, K, LB) + INTEGER, INTENT(IN) :: LA + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: LB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vac2.f90 b/src/appl/rci90_mpi/vac2.f90 index 1f56366b5..ddba6be40 100644 --- a/src/appl/rci90_mpi/vac2.f90 +++ b/src/appl/rci90_mpi/vac2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VAC2 + SUBROUTINE VAC2 ! * ! This routine sets up the second-order vacuum polarization poten- * ! tial using equations (1) and (4) of L Wayne Fullerton and G A * @@ -14,13 +14,13 @@ SUBROUTINE VAC2 ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE npar_C @@ -29,82 +29,82 @@ SUBROUTINE VAC2 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE funk_I - USE quad_I + USE funk_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K + INTEGER :: I, K REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TBI, RK, XK, XI, XM, XP !----------------------------------------------- ! ! Overall initialization ! - EPSI = PRECIS*PRECIS - TWOCV = CVAC + CVAC + EPSI = PRECIS*PRECIS + TWOCV = CVAC + CVAC ! ! Potential for a point nucleus: equation (1) ! (this is also the asymptotoc form for a finite nucleus) ! - FACTOR = -(2.0D00*Z)/(3.0D00*PI*CVAC) + FACTOR = -(2.0D00*Z)/(3.0D00*PI*CVAC) ! - TB(1) = 0.0D00 + TB(1) = 0.0D00 ! - I = 1 - 1 CONTINUE - I = I + 1 + I = 1 + 1 CONTINUE + I = I + 1 ! - RI = R(I) - X = TWOCV*RI - TBI = (FACTOR/RI)*FUNK(X,1) + RI = R(I) + X = TWOCV*RI + TBI = (FACTOR/RI)*FUNK(X,1) ! - IF (DABS(TBI) >= EPSI) THEN - TB(I) = TBI - IF (I < N) GO TO 1 - ELSE - TB(I:N) = 0.0D00 - ENDIF + IF (DABS(TBI) >= EPSI) THEN + TB(I) = TBI + IF (I < N) GO TO 1 + ELSE + TB(I:N) = 0.0D00 + ENDIF ! ! Potential for a finite nucleus: equation (4) ! - IF (NPARM == 2) THEN + IF (NPARM == 2) THEN ! - FACTOR = -2.0D00/(3.0D00*CVAC**2) + FACTOR = -2.0D00/(3.0D00*CVAC**2) ! ! Set up integrand ! - TB(1) = 0.0D00 + TB(1) = 0.0D00 ! - K = 1 - 3 CONTINUE - K = K + 1 + K = 1 + 3 CONTINUE + K = K + 1 ! - RK = R(K) - XK = TWOCV*RK + RK = R(K) + XK = TWOCV*RK ! - TA(1) = 0.0D00 - DO I = 2, MTP - XI = TWOCV*R(I) - XM = DABS(XK - XI) - XP = XK + XI - TA(I) = (FUNK(XM,0) - FUNK(XP,0))*ZDIST(I) - END DO + TA(1) = 0.0D00 + DO I = 2, MTP + XI = TWOCV*R(I) + XM = DABS(XK - XI) + XP = XK + XI + TA(I) = (FUNK(XM,0) - FUNK(XP,0))*ZDIST(I) + END DO ! - CALL QUAD (X) + CALL QUAD (X) ! - X = X*FACTOR/RK + X = X*FACTOR/RK ! ! Get out of loop if the asymptotic value has been attained ! - IF (DABS(X) >= EPSI) THEN - IF (DABS((X - TB(K))/X) > 1.0D-05) THEN - TB(K) = X - IF (K < N) GO TO 3 - ENDIF - ENDIF + IF (DABS(X) >= EPSI) THEN + IF (DABS((X - TB(K))/X) > 1.0D-05) THEN + TB(K) = X + IF (K < N) GO TO 3 + ENDIF + ENDIF ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE VAC2 + RETURN + END SUBROUTINE VAC2 diff --git a/src/appl/rci90_mpi/vac2_I.f90 b/src/appl/rci90_mpi/vac2_I.f90 index 442a068df..590dfd050 100644 --- a/src/appl/rci90_mpi/vac2_I.f90 +++ b/src/appl/rci90_mpi/vac2_I.f90 @@ -1,9 +1,9 @@ - MODULE vac2_I + MODULE vac2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vac2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vac2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vac4.f90 b/src/appl/rci90_mpi/vac4.f90 index fdb4b690c..c03683c89 100644 --- a/src/appl/rci90_mpi/vac4.f90 +++ b/src/appl/rci90_mpi/vac4.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VAC4 + SUBROUTINE VAC4 ! * ! This routine sets up the fourth-order vacuum polarization poten- * ! tial using equations (11) and (12) of L Wayne Fullerton and G A * @@ -14,13 +14,13 @@ SUBROUTINE VAC4 ! Written by Farid A Parpia, at Oxford Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE debug_C USE def_C @@ -31,108 +31,108 @@ SUBROUTINE VAC4 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE funl_I - USE quad_I + USE funl_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K, NB2, NROWS, II, II1, II2 - REAL(DOUBLE), DIMENSION(NNNP) :: TC + INTEGER :: I, K, NB2, NROWS, II, II1, II2 + REAL(DOUBLE), DIMENSION(NNNP) :: TC REAL(DOUBLE) :: EPSI, TWOCV, FACTOR, RI, X, TCI, RK, XK, XI, XM, XP !----------------------------------------------- ! ! Overall initialization ! - EPSI = PRECIS*PRECIS - TWOCV = CVAC + CVAC + EPSI = PRECIS*PRECIS + TWOCV = CVAC + CVAC ! ! Potential for point nucleus: equation (12) ! - FACTOR = -Z/(PI*CVAC)**2 + FACTOR = -Z/(PI*CVAC)**2 ! - TC(1) = 0.0D00 + TC(1) = 0.0D00 ! - I = 1 - 1 CONTINUE - I = I + 1 - RI = R(I) - X = TWOCV*RI - TCI = (FACTOR/RI)*FUNL(X,1) - IF (DABS(TCI) >= EPSI) THEN - TC(I) = TCI - IF (I < N) GO TO 1 - ELSE - TC(I:N) = 0.0D00 - ENDIF + I = 1 + 1 CONTINUE + I = I + 1 + RI = R(I) + X = TWOCV*RI + TCI = (FACTOR/RI)*FUNL(X,1) + IF (DABS(TCI) >= EPSI) THEN + TC(I) = TCI + IF (I < N) GO TO 1 + ELSE + TC(I:N) = 0.0D00 + ENDIF ! ! Potential for finite nucleus: equation (11) ! - IF (NPARM == 2) THEN + IF (NPARM == 2) THEN ! - FACTOR = -1.0D00/(PI*CVAC**3) + FACTOR = -1.0D00/(PI*CVAC**3) ! - TC(1) = 0.0D00 + TC(1) = 0.0D00 ! - K = 1 - 3 CONTINUE - K = K + 1 + K = 1 + 3 CONTINUE + K = K + 1 ! - RK = R(K) - XK = TWOCV*RK - TA(1) = 0.0D00 + RK = R(K) + XK = TWOCV*RK + TA(1) = 0.0D00 ! - DO I = 2, MTP - XI = TWOCV*R(I) - XM = DABS(XK - XI) - XP = XK + XI - TA(I) = (FUNL(XM,0) - FUNL(XP,0))*ZDIST(I) - END DO + DO I = 2, MTP + XI = TWOCV*R(I) + XM = DABS(XK - XI) + XP = XK + XI + TA(I) = (FUNL(XM,0) - FUNL(XP,0))*ZDIST(I) + END DO ! - CALL QUAD (X) + CALL QUAD (X) ! - X = X*FACTOR/RK + X = X*FACTOR/RK ! ! Get out of the loop if the asymptotic region has been reached ! - IF (DABS(X) >= EPSI) THEN - IF (DABS((TC(K)-X)/X) > 1.0D-03) THEN - TC(K) = X - IF (K < N) GO TO 3 - ENDIF - ENDIF -! - ENDIF -! - IF (LDBPR(8)) THEN - WRITE (99, 300) - NB2 = N/2 - IF (2*NB2 == N) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= N) THEN + IF (DABS(X) >= EPSI) THEN + IF (DABS((TC(K)-X)/X) > 1.0D-03) THEN + TC(K) = X + IF (K < N) GO TO 3 + ENDIF + ENDIF +! + ENDIF +! + IF (LDBPR(8)) THEN + WRITE (99, 300) + NB2 = N/2 + IF (2*NB2 == N) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= N) THEN WRITE (99, 301) R(II1), TB(II1), TC(II1), R(II2), TB(II2), TC(& - II2) - ELSE IF (II1 <= N) THEN - WRITE (99, 301) R(II1), TB(II1), TC(II1) - ENDIF - END DO - ENDIF + II2) + ELSE IF (II1 <= N) THEN + WRITE (99, 301) R(II1), TB(II1), TC(II1) + ENDIF + END DO + ENDIF ! ! Generate total vacuum-polarization potential ! - TB(:N) = TC(:N) + TB(:N) + TB(:N) = TC(:N) + TB(:N) ! - RETURN + RETURN ! 300 FORMAT(/,/,/,' ++++++++++ VAC4 ++++++++++'/,/,2(& - ' -------- r -------- ----- VV2 (r) -----',' ----- VV4 (r) -----')) - 301 FORMAT(1P,6(1X,1D19.12)) - RETURN + ' -------- r -------- ----- VV2 (r) -----',' ----- VV4 (r) -----')) + 301 FORMAT(1P,6(1X,1D19.12)) + RETURN ! - END SUBROUTINE VAC4 + END SUBROUTINE VAC4 diff --git a/src/appl/rci90_mpi/vac4_I.f90 b/src/appl/rci90_mpi/vac4_I.f90 index 92ea384de..98e74e2c7 100644 --- a/src/appl/rci90_mpi/vac4_I.f90 +++ b/src/appl/rci90_mpi/vac4_I.f90 @@ -1,9 +1,9 @@ - MODULE vac4_I + MODULE vac4_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vac4 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vac4 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vacpol.f90 b/src/appl/rci90_mpi/vacpol.f90 index 82747f01b..73a4a86fc 100644 --- a/src/appl/rci90_mpi/vacpol.f90 +++ b/src/appl/rci90_mpi/vacpol.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE VACPOL + SUBROUTINE VACPOL ! * ! This routine controls the setting up of the vacuum polarization * ! potential for the given nuclear charge distribution at each grid * @@ -14,13 +14,13 @@ SUBROUTINE VACPOL ! Written by Farid A Parpia, at Oxford Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE npar_C USE ncdist_C @@ -28,31 +28,31 @@ SUBROUTINE VACPOL !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE vac2_I - USE vac4_I + USE vac2_I + USE vac4_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! ! Redefine ZDIST to be rho*r*r' ! - ZDIST(:MTP) = ZDIST(:MTP)*R(:MTP)*RP(:MTP) + ZDIST(:MTP) = ZDIST(:MTP)*R(:MTP)*RP(:MTP) ! ! Second-order vacuum polarisation potential; returned in ! array TB ! - CALL VAC2 + CALL VAC2 ! ! Fourth-order vacuum polarization potential; returned in ! array TA ! - CALL VAC4 + CALL VAC4 ! ! If option 7 is set, use user-defined vacuum polarization ! potential ! - RETURN - END SUBROUTINE VACPOL + RETURN + END SUBROUTINE VACPOL diff --git a/src/appl/rci90_mpi/vacpol_I.f90 b/src/appl/rci90_mpi/vacpol_I.f90 index 6683ba54c..6c25cb73c 100644 --- a/src/appl/rci90_mpi/vacpol_I.f90 +++ b/src/appl/rci90_mpi/vacpol_I.f90 @@ -1,9 +1,9 @@ - MODULE vacpol_I + MODULE vacpol_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE vacpol - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE vacpol + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vint.f90 b/src/appl/rci90_mpi/vint.f90 index e313ebf43..3518e4286 100644 --- a/src/appl/rci90_mpi/vint.f90 +++ b/src/appl/rci90_mpi/vint.f90 @@ -12,8 +12,8 @@ SUBROUTINE VINT (IA,IB,TEGRAL) ! Written by Farid A Parpia Last revision: 06 Jun 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/vint_I.f90 b/src/appl/rci90_mpi/vint_I.f90 index dcc947ed9..176bfb53d 100644 --- a/src/appl/rci90_mpi/vint_I.f90 +++ b/src/appl/rci90_mpi/vint_I.f90 @@ -1,11 +1,11 @@ - MODULE vint_I + MODULE vint_I INTERFACE -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE VINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER , INTENT(IN) :: IA, IB REAl(DOUBLE), INTENT(OUT) :: TEGRAL END SUBROUTINE vint - END INTERFACE - END MODULE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vinti.f90 b/src/appl/rci90_mpi/vinti.f90 index 3bcedf4f9..f6875132b 100644 --- a/src/appl/rci90_mpi/vinti.f90 +++ b/src/appl/rci90_mpi/vinti.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) + REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! * ! The value of this function is the one-electron integral V (J,K) * ! for orbitals J, K. The analytical expression for this quantity * @@ -12,13 +12,13 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! Written by M Tong and F A Parpia, Last revision: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE grid_C USE orb_C @@ -27,56 +27,56 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dpbdt_I - USE quad_I + USE dpbdt_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: K + INTEGER :: J + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 - REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 + INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 + REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 !----------------------------------------------- ! - MTP = MAX(MF(J),MF(K)) + MTP = MAX(MF(J),MF(K)) ! ! Piece involving derivatives ! - CALL DPBDT (K) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = PIECE1/H + CALL DPBDT (K) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = PIECE1/H ! ! Pieces not involving derivatives ! - KPJ = NAK(J) - KPK = NAK(K) - IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) - FACT1 = 0.5D00*DBLE(IFACT1) - IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) - FACT2 = 0.5D00*DBLE(IFACT2) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K)) - END DO - CALL QUAD (PIECE2) + KPJ = NAK(J) + KPK = NAK(K) + IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) + FACT1 = 0.5D00*DBLE(IFACT1) + IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) + FACT2 = 0.5D00*DBLE(IFACT2) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K)) + END DO + CALL QUAD (PIECE2) ! - VINTI = PIECE1 - PIECE2 + VINTI = PIECE1 - PIECE2 ! ! Debug printout ! - IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI + IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI ! - RETURN + RETURN ! - 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) - RETURN + 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) + RETURN ! - END FUNCTION VINTI + END FUNCTION VINTI diff --git a/src/appl/rci90_mpi/vinti_I.f90 b/src/appl/rci90_mpi/vinti_I.f90 index 3ae6f3a41..d9af3126a 100644 --- a/src/appl/rci90_mpi/vinti_I.f90 +++ b/src/appl/rci90_mpi/vinti_I.f90 @@ -1,11 +1,11 @@ - MODULE vinti_I + MODULE vinti_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION vinti (J, K) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION vinti (J, K) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vpint.f90 b/src/appl/rci90_mpi/vpint.f90 index a88f078b0..5988326fd 100644 --- a/src/appl/rci90_mpi/vpint.f90 +++ b/src/appl/rci90_mpi/vpint.f90 @@ -10,7 +10,7 @@ SUBROUTINE VPINT (IA,IB,TEGRAL) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/vpint_I.f90 b/src/appl/rci90_mpi/vpint_I.f90 index 6403d7edf..93f22a2e5 100644 --- a/src/appl/rci90_mpi/vpint_I.f90 +++ b/src/appl/rci90_mpi/vpint_I.f90 @@ -1,11 +1,11 @@ - MODULE vpint_I + MODULE vpint_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE VPINT (IA,IB,TEGRAL) USE vast_kind_param, ONLY: DOUBLE INTEGER , INTENT(INOUT) :: IA, IB REAl(DOUBLE), INTENT(OUT) :: TEGRAL - END SUBROUTINE vpint - END INTERFACE - END MODULE + END SUBROUTINE vpint + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/vpintf.f90 b/src/appl/rci90_mpi/vpintf.f90 index e52a48ca0..0de94573d 100644 --- a/src/appl/rci90_mpi/vpintf.f90 +++ b/src/appl/rci90_mpi/vpintf.f90 @@ -8,7 +8,7 @@ REAL(KIND(0.0D0)) FUNCTION VPINTF (IA,IB) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rci90_mpi/vpintf_I.f90 b/src/appl/rci90_mpi/vpintf_I.f90 index a663f87ad..4593275fd 100644 --- a/src/appl/rci90_mpi/vpintf_I.f90 +++ b/src/appl/rci90_mpi/vpintf_I.f90 @@ -1,9 +1,9 @@ - MODULE vpintf_I + MODULE vpintf_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(KIND(0.0D0)) FUNCTION VPINTF (IA,IB) INTEGER , INTENT(IN) :: IA, IB - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/wghtd5.f90 b/src/appl/rci90_mpi/wghtd5.f90 index a66ac2f90..f6936be95 100644 --- a/src/appl/rci90_mpi/wghtd5.f90 +++ b/src/appl/rci90_mpi/wghtd5.f90 @@ -10,7 +10,7 @@ SUBROUTINE WGHTD5(iatjpo, iaspar) ! Last updated: 02 Nov 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -34,7 +34,7 @@ SUBROUTINE WGHTD5(iatjpo, iaspar) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - + INTEGER, DIMENSION(5) :: ICONF ! REAL(DOUBLE), DIMENSION(5) :: WGHT(5) REAL(DOUBLE), DIMENSION(5) :: WT(5) diff --git a/src/appl/rci90_mpi/wghtd5_I.f90 b/src/appl/rci90_mpi/wghtd5_I.f90 index 56f643140..6d837033a 100644 --- a/src/appl/rci90_mpi/wghtd5_I.f90 +++ b/src/appl/rci90_mpi/wghtd5_I.f90 @@ -1,9 +1,9 @@ MODULE wghtd5_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE WGHTD5(iatjpo, iaspar) INTEGER, INTENT(IN) :: iatjpo, iaspar - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rci90_mpi/zkf.f90 b/src/appl/rci90_mpi/zkf.f90 index 90c0cd5cc..d630b5083 100644 --- a/src/appl/rci90_mpi/zkf.f90 +++ b/src/appl/rci90_mpi/zkf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ZKF(K, I, J) + SUBROUTINE ZKF(K, I, J) ! * ! This subroutine evaluates Hartree Z-functionals: * ! * @@ -14,13 +14,13 @@ SUBROUTINE ZKF(K, I, J) ! Written by Farid A Parpia, at Oxford Last updated: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNN1 USE cnc_C, ONLY: cnc5c USE grid_C, ONLY: n, r, rp @@ -30,81 +30,81 @@ SUBROUTINE ZKF(K, I, J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: K - INTEGER :: I + INTEGER, INTENT(IN) :: K + INTEGER :: I INTEGER :: J !!!! Arument not referenced !!! !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II, MTPP1, MTPP3, MTPP4, KK + INTEGER :: II, MTPP1, MTPP3, MTPP4, KK REAL(DOUBLE), DIMENSION(NNN1) :: RHOP, RTTK, TEMP - REAL(DOUBLE) :: SUM, ZKLIM + REAL(DOUBLE) :: SUM, ZKLIM !----------------------------------------------- ! - IF (K > 0) THEN - RTTK(2:N) = R(2:N)**K - ENDIF + IF (K > 0) THEN + RTTK(2:N) = R(2:N)**K + ENDIF ! ! MTP is fed in through COMMON/TATB/ ! - MTPP1 = MTP + 1 - MTPP3 = MTP + 3 - MTPP4 = MTP + 4 + MTPP1 = MTP + 1 + MTPP3 = MTP + 3 + MTPP4 = MTP + 4 ! ! Compute RP(S)*F(S) and store it in RHOP ! - RHOP(2:MTP) = RP(2:MTP)*TA(2:MTP) + RHOP(2:MTP) = RP(2:MTP)*TA(2:MTP) ! ! Fill array TEMP with r**k * RHOP ! - TEMP(1) = 0.0D00 - IF (K == 0) THEN - TEMP(2:MTP) = RHOP(2:MTP) - ELSE - TEMP(2:MTP) = RTTK(2:MTP)*RHOP(2:MTP) - ENDIF + TEMP(1) = 0.0D00 + IF (K == 0) THEN + TEMP(2:MTP) = RHOP(2:MTP) + ELSE + TEMP(2:MTP) = RTTK(2:MTP)*RHOP(2:MTP) + ENDIF ! ! Set an additional four points to zero ! - TEMP(MTPP1:MTPP4) = 0.0D00 + TEMP(MTPP1:MTPP4) = 0.0D00 ! ! k ! Compute the first few values of r * ZK using semi-open ! Newton-Cotes formulae ! - ZK(1) = 0.0D00 - DO II = 2, 4 - SUM = 0.0D00 - DO KK = 2, 5 - SUM = SUM + CNC5C(KK,II)*TEMP(KK) - END DO - ZK(II) = SUM - END DO + ZK(1) = 0.0D00 + DO II = 2, 4 + SUM = 0.0D00 + DO KK = 2, 5 + SUM = SUM + CNC5C(KK,II)*TEMP(KK) + END DO + ZK(II) = SUM + END DO ! k ! Compute remainder of r * ZK: march out to MTP+3 ! - DO II = 5, MTPP3 + DO II = 5, MTPP3 ZK(II) = ZK(II-4) + C1*(TEMP(II-4)+TEMP(II)) + C2*(TEMP(II-3)+TEMP(II-& - 1)) + C3*TEMP(II-2) - END DO + 1)) + C3*TEMP(II-2) + END DO ! k (k) ! Determine the asymptotic value of r * Z ! ! Compute ZK ! - ZKLIM = ZK(MTPP3) + ZKLIM = ZK(MTPP3) ! - IF (K == 0) THEN + IF (K == 0) THEN ! - ZK(MTPP4:N) = ZKLIM + ZK(MTPP4:N) = ZKLIM ! - ELSE + ELSE ! - ZK(2:MTPP3) = ZK(2:MTPP3)/RTTK(2:MTPP3) + ZK(2:MTPP3) = ZK(2:MTPP3)/RTTK(2:MTPP3) ! - ZK(MTPP4:N) = ZKLIM/RTTK(MTPP4:N) + ZK(MTPP4:N) = ZKLIM/RTTK(MTPP4:N) ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE ZKF + RETURN + END SUBROUTINE ZKF diff --git a/src/appl/rci90_mpi/zkf_I.f90 b/src/appl/rci90_mpi/zkf_I.f90 index 6ccb20617..442ede952 100644 --- a/src/appl/rci90_mpi/zkf_I.f90 +++ b/src/appl/rci90_mpi/zkf_I.f90 @@ -1,12 +1,12 @@ - MODULE zkf_I + MODULE zkf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE zkf (K, I, J) - INTEGER, INTENT(IN) :: K - INTEGER :: I - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE zkf (K, I, J) + INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/Makefile b/src/appl/rcsfgenerate90/Makefile index 0d08e1c30..618c270a0 100644 --- a/src/appl/rcsfgenerate90/Makefile +++ b/src/appl/rcsfgenerate90/Makefile @@ -1,4 +1,4 @@ -.SUFFIXES: .f90 .mod +.SUFFIXES: .f90 .mod EXE = rcsfgenerate BINDIR = ${GRASP}/bin @@ -24,10 +24,10 @@ APP_OBJ= \ genb.o jjgen15b.o kopp1.o kopp2.o lasa1.o lasa2.o lika.o \ lockad.o matain.o matcin.o matbin.o merge.o mergeb.o \ reada.o reffa.o slug.o sluggo.o test.o copy7t9.o open79.o \ - rcsfblock.o rcsfexcitation.o wrapper.o + rcsfblock.o rcsfexcitation.o wrapper.o $(EXE): $(MOD_OBJ) $(APP_OBJ) - $(FC) -o $(BINFILE) $(LD_FLAGS) $(APP_OBJ) -L$(GRASPLIB) $(GRASPLIBS) + $(FC) -o $(BINFILE) $(LD_FLAGS) $(APP_OBJ) -L$(GRASPLIB) $(GRASPLIBS) .f90.o: $(FC) -c $(FC_FLAGS) $< -I . -I ${MODDIR} -I $(MODL9290) -o $@ @@ -38,4 +38,3 @@ $(EXE): $(MOD_OBJ) $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rcsfgenerate90/adder.f90 b/src/appl/rcsfgenerate90/adder.f90 index 4ff4adc1b..6e5601162 100644 --- a/src/appl/rcsfgenerate90/adder.f90 +++ b/src/appl/rcsfgenerate90/adder.f90 @@ -1,112 +1,112 @@ ! last edited July 31, 1996 - subroutine adder(closed, med, slut, anel, par, expand) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine adder(closed, med, slut, anel, par, expand) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use lockad_I - use lasa1_I + use lockad_I + use lasa1_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(out) :: anel - integer , intent(out) :: par - logical :: slut - logical :: expand - logical :: closed(15,0:10) - logical :: med(15,0:10) + integer , intent(out) :: anel + integer , intent(out) :: par + logical :: slut + logical :: expand + logical :: closed(15,0:10) + logical :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop - integer :: skal, i, j, kl, nr - logical :: finns - character :: rad1*500, rad2*500, rad3*500 + integer , dimension(15,0:10,0:1) :: pop + integer :: skal, i, j, kl, nr + logical :: finns + character :: rad1*500, rad2*500, rad3*500 !----------------------------------------------- - skal = 20 - inquire(file='clist.inp', exist=finns) - if (finns) then - if (.not.expand) then - open(unit=fil_1, file='clist.inp', status='old', position='asis') - else - open(unit=fil_2, file='clist.inp', status='old', position='asis') - endif - slut = .FALSE. - call lockad (closed, med, slut, expand) - if (.not.slut) then - if (expand) then - read (fil_2, *, end=99) - call lasa1 (fil_2, rad1, pop, skal, slut) - else - read (fil_1, *, end=99) - call lasa1 (fil_1, rad1, pop, skal, slut) - endif - endif - if (.not.slut) then - anel = 0 - par = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - if (closed(i,j)) then - anel = anel + 2 + 4*j - else - anel = anel + pop(i,j,0) + pop(i,j,1) - par = mod(par + j*(pop(i,j,0)+pop(i,j,1)),2) - endif - end do - end do - if (expand) then - read (fil_2, 100, end=99) rad2 - read (fil_2, 100, end=99) rad3 - else - read (fil_1, 100, end=99) rad2 - read (fil_1, 100, end=99) rad3 - endif - kl = skal*9 - if (rad3(kl:kl) /= '/') then - if (rad3(kl:kl) /= ' ') then - nr = 10*(ichar(rad3(kl:kl))-ichar('0')) - else - nr = 0 - endif - kl = kl + 1 + skal = 20 + inquire(file='clist.inp', exist=finns) + if (finns) then + if (.not.expand) then + open(unit=fil_1, file='clist.inp', status='old', position='asis') + else + open(unit=fil_2, file='clist.inp', status='old', position='asis') + endif + slut = .FALSE. + call lockad (closed, med, slut, expand) + if (.not.slut) then + if (expand) then + read (fil_2, *, end=99) + call lasa1 (fil_2, rad1, pop, skal, slut) + else + read (fil_1, *, end=99) + call lasa1 (fil_1, rad1, pop, skal, slut) + endif + endif + if (.not.slut) then + anel = 0 + par = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + if (closed(i,j)) then + anel = anel + 2 + 4*j + else + anel = anel + pop(i,j,0) + pop(i,j,1) + par = mod(par + j*(pop(i,j,0)+pop(i,j,1)),2) + endif + end do + end do + if (expand) then + read (fil_2, 100, end=99) rad2 + read (fil_2, 100, end=99) rad3 + else + read (fil_1, 100, end=99) rad2 + read (fil_1, 100, end=99) rad3 + endif + kl = skal*9 + if (rad3(kl:kl) /= '/') then + if (rad3(kl:kl) /= ' ') then + nr = 10*(ichar(rad3(kl:kl))-ichar('0')) + else + nr = 0 + endif + kl = kl + 1 if (rad3(kl:kl) /= ' ') nr = nr + (ichar(rad3(kl:kl))-ichar('0')& - ) - else - kl = skal*9 - 2 - if (rad3(kl:kl) /= ' ') then - nr = 10*(ichar(rad3(kl:kl))-ichar('0')) - else - nr = 0 - endif - kl = kl + 1 - nr = nr + ichar(rad3(kl:kl)) - ichar('0') - endif - endif - if (expand) then - rewind (fil_2) - else - rewind (fil_1) - endif - else - slut = .TRUE. - endif - return - 99 continue - slut = .TRUE. - if (expand) then - close(fil_2) - else - close(fil_1) - endif - return - 100 format(a) - return - end subroutine adder + ) + else + kl = skal*9 - 2 + if (rad3(kl:kl) /= ' ') then + nr = 10*(ichar(rad3(kl:kl))-ichar('0')) + else + nr = 0 + endif + kl = kl + 1 + nr = nr + ichar(rad3(kl:kl)) - ichar('0') + endif + endif + if (expand) then + rewind (fil_2) + else + rewind (fil_1) + endif + else + slut = .TRUE. + endif + return + 99 continue + slut = .TRUE. + if (expand) then + close(fil_2) + else + close(fil_1) + endif + return + 100 format(a) + return + end subroutine adder diff --git a/src/appl/rcsfgenerate90/adder_I.f90 b/src/appl/rcsfgenerate90/adder_I.f90 index e1936e390..240faf7c8 100644 --- a/src/appl/rcsfgenerate90/adder_I.f90 +++ b/src/appl/rcsfgenerate90/adder_I.f90 @@ -1,13 +1,13 @@ - MODULE adder_I + MODULE adder_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE adder (CLOSED, MED, SLUT, ANEL, PAR, EXPAND) - LOGICAL, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - LOGICAL, DIMENSION(15,0:10) :: MED - LOGICAL, INTENT(OUT) :: SLUT - INTEGER, INTENT(OUT) :: ANEL - INTEGER, INTENT(OUT) :: PAR - LOGICAL, INTENT(IN) :: EXPAND - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE adder (CLOSED, MED, SLUT, ANEL, PAR, EXPAND) + LOGICAL, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + LOGICAL, DIMENSION(15,0:10) :: MED + LOGICAL, INTENT(OUT) :: SLUT + INTEGER, INTENT(OUT) :: ANEL + INTEGER, INTENT(OUT) :: PAR + LOGICAL, INTENT(IN) :: EXPAND + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/blanda.f90 b/src/appl/rcsfgenerate90/blanda.f90 index 845987b8b..56ab24a02 100644 --- a/src/appl/rcsfgenerate90/blanda.f90 +++ b/src/appl/rcsfgenerate90/blanda.f90 @@ -1,46 +1,46 @@ ! last edited Januar 2, 1997 subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & - posl, lim, dubbel, first) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + posl, lim, dubbel, first) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use slug_I - use gen_I + use slug_I + use gen_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer :: minj - integer :: maxj - integer :: skal - integer , intent(in) :: nmax - logical :: first - integer :: org(15,0:10) - integer :: low(15,0:10) - integer :: posn(110) - integer :: posl(110) - integer , intent(in) :: lim(15) - logical :: lock(15,0:10) - logical :: dubbel(15,0:10) + integer :: varmax + integer :: minj + integer :: maxj + integer :: skal + integer , intent(in) :: nmax + logical :: first + integer :: org(15,0:10) + integer :: low(15,0:10) + integer :: posn(110) + integer :: posl(110) + integer , intent(in) :: lim(15) + logical :: lock(15,0:10) + logical :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: antel, start - integer :: cf - integer , dimension(15,0:10,0:1) :: ansats - integer , dimension(15,0:10) :: varupp, varned + integer , dimension(15,0:10) :: antel, start + integer :: cf + integer , dimension(15,0:10,0:1) :: ansats + integer , dimension(15,0:10) :: varupp, varned integer :: an10, an20, an21, an30, an31, an32, an40, an41, an42, an43, k& , an50, an51, an52, an53, an54, an60, an61, an62, an63, an64, an65, & - an70, an71, an72, an73, an74, an75, an76 - integer , dimension(15,0:10) :: stopp + an70, an71, an72, an73, an74, an75, an76 + integer , dimension(15,0:10) :: stopp integer :: an80, an81, an82, an83, an84, an85, an86, an87, an90, an91, & an92, an93, an94, an95, an96, an97, an98, ana0, ana1, ana2, ana3, ana4& , ana5, ana6, ana7, ana8, ana9, plus21, plus31, plus32, plus41, plus42& @@ -49,10 +49,10 @@ subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & , plus82, plus83, plus84, plus85, plus86, plus87, plus91, plus92, & plus93, plus94, plus95, plus96, plus97, plus98, plusa1, plusa2, plusa3& , plusa4, plusa5, plusa6, plusa7, plusa8, plusa9, par0, par, ress, & - resl, i, j, antal - integer , dimension(15,0:10) :: steg - integer :: dum, ras1, ras3, elar, rasett, rastre - integer , dimension(15,0:10) :: ras + resl, i, j, antal + integer , dimension(15,0:10) :: steg + integer :: dum, ras1, ras3, elar, rasett, rastre + integer , dimension(15,0:10) :: ras integer :: plusba, plusca, plusda, plusea, plusfa, plusb1, plusb2, plusb3& , plusb4, plusb5, plusb6, plusb7, plusb8, plusb9, plusc1, plusc2, & plusc3, plusc4, plusc5, plusc6, plusc7, plusc8, plusc9, plusd1, plusd2& @@ -63,1602 +63,1602 @@ subroutine blanda(org, varmax, lock, minj, maxj, skal, nmax, low, posn, & anb7, anb8, anb9, anc0, anc1, anc2, anc3, anc4, anc5, anc6, anc7, anc8& , anc9, and0, and1, and2, and3, and4, and5, and6, and7, and8, and9, & ane0, ane1, ane2, ane3, ane4, ane5, ane6, ane7, ane8, ane9, anf0, anf1& - , anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 - logical :: finns, napp + , anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 + logical :: finns, napp !----------------------------------------------- - - cf = 0 - antal = 0 - par0 = 0 - finns = .FALSE. - do i = 1, nmax - do j = 0, min(10,i - 1) - if (dubbel(i,j)) then - steg(i,j) = -2 - else - steg(i,j) = -1 - endif - antal = antal + org(i,j) - par0 = mod(par0 + j*org(i,j),2) - end do - end do - if (nmax < 15) then - do i = nmax + 1, 15 - steg(i,:min(10,i-1)) = -1 - end do - endif + + cf = 0 + antal = 0 + par0 = 0 + finns = .FALSE. + do i = 1, nmax + do j = 0, min(10,i - 1) + if (dubbel(i,j)) then + steg(i,j) = -2 + else + steg(i,j) = -1 + endif + antal = antal + org(i,j) + par0 = mod(par0 + j*org(i,j),2) + end do + end do + if (nmax < 15) then + do i = nmax + 1, 15 + steg(i,:min(10,i-1)) = -1 + end do + endif ! 1s call slug (1, 0, varmax, varupp, varned, ansats, org, lock(1,0), dubbel, & - low, start(1,0), stopp(1,0)) - do an10 = start(1,0), stopp(1,0), steg(1,0) - antel(1,0) = an10 - if (antel(1,0)>antal .or. antel(1,0)antal .or. antel(1,0) antal) cycle - ansats(2,0,0) = an20 + dubbel, low, start(2,0), stopp(2,0)) + do an20 = start(2,0), stopp(2,0), steg(2,0) + antel(2,0) = an20 + antel(1,0) + if (antel(2,0) > antal) cycle + ansats(2,0,0) = an20 ! 2p call slug (2, 1, varmax, varupp, varned, ansats, org, lock(2,1), & - dubbel, low, start(2,1), stopp(2,1)) - do an21 = start(2,1), stopp(2,1), steg(2,1) - antel(2,1) = an21 + antel(2,0) - if (antel(2,1)>antal .or. antel(2,1)antal .or. antel(2,1) antal) cycle - ansats(3,0,0) = an30 + 0), dubbel, low, start(3,0), stopp(3,0)) + do an30 = start(3,0), stopp(3,0), steg(3,0) + antel(3,0) = an30 + antel(2,1) + if (antel(3,0) > antal) cycle + ansats(3,0,0) = an30 ! 3p call slug (3, 1, varmax, varupp, varned, ansats, org, lock& - (3,1), dubbel, low, start(3,1), stopp(3,1)) - do an31 = start(3,1), stopp(3,1), steg(3,1) - antel(3,1) = an31 + antel(3,0) - if (antel(3,1) > antal) cycle - do plus31 = min(an31,4), max(an31 - 2,0), -1 - ansats(3,1,1) = plus31 - ansats(3,1,0) = an31 - plus31 + (3,1), dubbel, low, start(3,1), stopp(3,1)) + do an31 = start(3,1), stopp(3,1), steg(3,1) + antel(3,1) = an31 + antel(3,0) + if (antel(3,1) > antal) cycle + do plus31 = min(an31,4), max(an31 - 2,0), -1 + ansats(3,1,1) = plus31 + ansats(3,1,0) = an31 - plus31 ! 3d call slug (3, 2, varmax, varupp, varned, ansats, org& - , lock(3,2), dubbel, low, start(3,2), stopp(3,2)) - do an32 = start(3,2), stopp(3,2), steg(3,2) - antel(3,2) = an32 + antel(3,1) + , lock(3,2), dubbel, low, start(3,2), stopp(3,2)) + do an32 = start(3,2), stopp(3,2), steg(3,2) + antel(3,2) = an32 + antel(3,1) if (antel(3,2)>antal .or. antel(3,2) antal) cycle - ansats(4,0,0) = an40 + 4,0), stopp(4,0)) + do an40 = start(4,0), stopp(4,0), steg(4,0) + antel(4,0) = an40 + antel(3,2) + if (antel(4,0) > antal) cycle + ansats(4,0,0) = an40 ! 4p call slug (4, 1, varmax, varupp, varned, & ansats, org, lock(4,1), dubbel, low, & - start(4,1), stopp(4,1)) - do an41 = start(4,1), stopp(4,1), steg(4,1) - antel(4,1) = an41 + antel(4,0) - if (antel(4,1) > antal) cycle + start(4,1), stopp(4,1)) + do an41 = start(4,1), stopp(4,1), steg(4,1) + antel(4,1) = an41 + antel(4,0) + if (antel(4,1) > antal) cycle do plus41 = min(an41,4), max(an41 - 2,0), & - -1 - ansats(4,1,1) = plus41 - ansats(4,1,0) = an41 - plus41 + -1 + ansats(4,1,1) = plus41 + ansats(4,1,0) = an41 - plus41 ! 4d call slug (4, 2, varmax, varupp, varned, & ansats, org, lock(4,2), dubbel, low, & - start(4,2), stopp(4,2)) - do an42 = start(4,2), stopp(4,2), steg(4,2) - antel(4,2) = an42 + antel(4,1) - if (antel(4,2) > antal) cycle + start(4,2), stopp(4,2)) + do an42 = start(4,2), stopp(4,2), steg(4,2) + antel(4,2) = an42 + antel(4,1) + if (antel(4,2) > antal) cycle do plus42 = min(an42,6), max(an42 - 4,0), & - -1 - ansats(4,2,1) = plus42 - ansats(4,2,0) = an42 - plus42 + -1 + ansats(4,2,1) = plus42 + ansats(4,2,0) = an42 - plus42 ! 4f call slug (4, 3, varmax, varupp, varned, & ansats, org, lock(4,3), dubbel, low, & - start(4,3), stopp(4,3)) - do an43 = start(4,3), stopp(4,3), steg(4,3) - antel(4,3) = an43 + antel(4,2) + start(4,3), stopp(4,3)) + do an43 = start(4,3), stopp(4,3), steg(4,3) + antel(4,3) = an43 + antel(4,2) if (antel(4,3)>antal .or. antel(4,3) antal) cycle - ansats(5,0,0) = an50 + start(5,0), stopp(5,0)) + do an50 = start(5,0), stopp(5,0), steg(5,0) + antel(5,0) = an50 + antel(4,3) + if (antel(5,0) > antal) cycle + ansats(5,0,0) = an50 ! 5p call slug (5, 1, varmax, varupp, varned, & ansats, org, lock(5,1), dubbel, low, & - start(5,1), stopp(5,1)) - do an51 = start(5,1), stopp(5,1), steg(5,1) - antel(5,1) = an51 + antel(5,0) - if (antel(5,1) > antal) cycle + start(5,1), stopp(5,1)) + do an51 = start(5,1), stopp(5,1), steg(5,1) + antel(5,1) = an51 + antel(5,0) + if (antel(5,1) > antal) cycle do plus51 = min(an51,4), max(an51 - 2,0), & - -1 - ansats(5,1,1) = plus51 - ansats(5,1,0) = an51 - plus51 + -1 + ansats(5,1,1) = plus51 + ansats(5,1,0) = an51 - plus51 ! 5d call slug (5, 2, varmax, varupp, varned, & ansats, org, lock(5,2), dubbel, low, & - start(5,2), stopp(5,2)) - do an52 = start(5,2), stopp(5,2), steg(5,2) - antel(5,2) = an52 + antel(5,1) - if (antel(5,2) > antal) cycle + start(5,2), stopp(5,2)) + do an52 = start(5,2), stopp(5,2), steg(5,2) + antel(5,2) = an52 + antel(5,1) + if (antel(5,2) > antal) cycle do plus52 = min(an52,6), max(an52 - 4,0), & - -1 - ansats(5,2,1) = plus52 - ansats(5,2,0) = an52 - plus52 - + -1 + ansats(5,2,1) = plus52 + ansats(5,2,0) = an52 - plus52 + ! 5f call slug (5, 3, varmax, varupp, varned, & ansats, org, lock(5,3), dubbel, low, & - start(5,3), stopp(5,3)) - do an53 = start(5,3), stopp(5,3), steg(5,3) - antel(5,3) = an53 + antel(5,2) - if (antel(5,3) > antal) cycle + start(5,3), stopp(5,3)) + do an53 = start(5,3), stopp(5,3), steg(5,3) + antel(5,3) = an53 + antel(5,2) + if (antel(5,3) > antal) cycle do plus53 = min(an53,8), max(an53 - 6,0), & - -1 - ansats(5,3,1) = plus53 - ansats(5,3,0) = an53 - plus53 + -1 + ansats(5,3,1) = plus53 + ansats(5,3,0) = an53 - plus53 ! 5g call slug (5, 4, varmax, varupp, varned, & ansats, org, lock(5,4), dubbel, low, & - start(5,4), stopp(5,4)) - do an54 = start(5,4), stopp(5,4), steg(5,4) - antel(5,4) = an54 + antel(5,3) + start(5,4), stopp(5,4)) + do an54 = start(5,4), stopp(5,4), steg(5,4) + antel(5,4) = an54 + antel(5,3) if (antel(5,4)>antal .or. antel(5,4)antal .or. ansats(5,4,1)>2) & - cycle - ansats(6,0,0) = an60 + cycle + ansats(6,0,0) = an60 ! 6p call slug (6, 1, varmax, varupp, varned, & ansats, org, lock(6,1), dubbel, low, & - start(6,1), stopp(6,1)) - do an61 = start(6,1), stopp(6,1), steg(6,1) - antel(6,1) = an61 + antel(6,0) - if (antel(6,1) > antal) cycle + start(6,1), stopp(6,1)) + do an61 = start(6,1), stopp(6,1), steg(6,1) + antel(6,1) = an61 + antel(6,0) + if (antel(6,1) > antal) cycle do plus61 = min(an61,4), max(an61 - 2,0), & - -1 - ansats(6,1,1) = plus61 - ansats(6,1,0) = an61 - plus61 + -1 + ansats(6,1,1) = plus61 + ansats(6,1,0) = an61 - plus61 ! 6d call slug (6, 2, varmax, varupp, varned, & ansats, org, lock(6,2), dubbel, low, & - start(6,2), stopp(6,2)) - do an62 = start(6,2), stopp(6,2), steg(6,2) - antel(6,2) = an62 + antel(6,1) - if (antel(6,2) > antal) cycle + start(6,2), stopp(6,2)) + do an62 = start(6,2), stopp(6,2), steg(6,2) + antel(6,2) = an62 + antel(6,1) + if (antel(6,2) > antal) cycle do plus62 = min(an62,6), max(an62 - 4,0), & - -1 - ansats(6,2,1) = plus62 - ansats(6,2,0) = an62 - plus62 + -1 + ansats(6,2,1) = plus62 + ansats(6,2,0) = an62 - plus62 ! 6f call slug (6, 3, varmax, varupp, varned, & ansats, org, lock(6,3), dubbel, low, & - start(6,3), stopp(6,3)) - do an63 = start(6,3), stopp(6,3), steg(6,3) - antel(6,3) = an63 + antel(6,2) - if (antel(6,3) > antal) cycle + start(6,3), stopp(6,3)) + do an63 = start(6,3), stopp(6,3), steg(6,3) + antel(6,3) = an63 + antel(6,2) + if (antel(6,3) > antal) cycle do plus63 = min(an63,8), max(an63 - 6,0), & - -1 - ansats(6,3,1) = plus63 - ansats(6,3,0) = an63 - plus63 + -1 + ansats(6,3,1) = plus63 + ansats(6,3,0) = an63 - plus63 ! 6g call slug (6, 4, varmax, varupp, varned, & ansats, org, lock(6,4), dubbel, low, & - start(6,4), stopp(6,4)) - do an64 = start(6,4), stopp(6,4), steg(6,4) - antel(6,4) = an64 + antel(6,3) - if (antel(6,4) > antal) cycle + start(6,4), stopp(6,4)) + do an64 = start(6,4), stopp(6,4), steg(6,4) + antel(6,4) = an64 + antel(6,3) + if (antel(6,4) > antal) cycle do plus64 = min(an64,10), max(an64 - 8,0), & - -1 - ansats(6,4,1) = plus64 - ansats(6,4,0) = an64 - plus64 + -1 + ansats(6,4,1) = plus64 + ansats(6,4,0) = an64 - plus64 ! 6h call slug (6, 5, varmax, varupp, varned, & ansats, org, lock(6,5), dubbel, low, & - start(6,5), stopp(6,5)) - do an65 = start(6,5), stopp(6,5), steg(6,5) - antel(6,5) = an65 + antel(6,4) + start(6,5), stopp(6,5)) + do an65 = start(6,5), stopp(6,5), steg(6,5) + antel(6,5) = an65 + antel(6,4) if (.not.(antel(6,5)<=antal .and. ansats(6,& 4,1)<=2 .and. antel(6,5)>=lim(6))) & - cycle + cycle do plus65 = min(an65,12), max(an65 - 10,0)& - , -1 - ansats(6,5,1) = plus65 - ansats(6,5,0) = an65 - plus65 + , -1 + ansats(6,5,1) = plus65 + ansats(6,5,0) = an65 - plus65 ! 7s call slug (7, 0, varmax, varupp, varned, & ansats, org, lock(7,0), dubbel, low, & - start(7,0), stopp(7,0)) - do an70 = start(7,0), stopp(7,0), steg(7,0) - antel(7,0) = an70 + antel(6,5) + start(7,0), stopp(7,0)) + do an70 = start(7,0), stopp(7,0), steg(7,0) + antel(7,0) = an70 + antel(6,5) if (.not.(antel(7,0)<=antal .and. ansats(6,& - 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle - ansats(7,0,0) = an70 + 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle + ansats(7,0,0) = an70 ! 7p call slug (7, 1, varmax, varupp, varned, & ansats, org, lock(7,1), dubbel, low, & - start(7,1), stopp(7,1)) - do an71 = start(7,1), stopp(7,1), steg(7,1) - antel(7,1) = an71 + antel(7,0) - if (antel(7,1) > antal) cycle + start(7,1), stopp(7,1)) + do an71 = start(7,1), stopp(7,1), steg(7,1) + antel(7,1) = an71 + antel(7,0) + if (antel(7,1) > antal) cycle do plus71 = min(an71,4), max(an71 - 2,0), & - -1 - ansats(7,1,1) = plus71 - ansats(7,1,0) = an71 - plus71 + -1 + ansats(7,1,1) = plus71 + ansats(7,1,0) = an71 - plus71 ! 7d call slug (7, 2, varmax, varupp, varned, & ansats, org, lock(7,2), dubbel, low, & - start(7,2), stopp(7,2)) - do an72 = start(7,2), stopp(7,2), steg(7,2) - antel(7,2) = an72 + antel(7,1) - if (antel(7,2) > antal) cycle + start(7,2), stopp(7,2)) + do an72 = start(7,2), stopp(7,2), steg(7,2) + antel(7,2) = an72 + antel(7,1) + if (antel(7,2) > antal) cycle do plus72 = min(an72,6), max(an72 - 4,0), & - -1 - ansats(7,2,1) = plus72 - ansats(7,2,0) = an72 - plus72 + -1 + ansats(7,2,1) = plus72 + ansats(7,2,0) = an72 - plus72 ! 7f call slug (7, 3, varmax, varupp, varned, & ansats, org, lock(7,3), dubbel, low, & - start(7,3), stopp(7,3)) - do an73 = start(7,3), stopp(7,3), steg(7,3) - antel(7,3) = an73 + antel(7,2) - if (antel(7,3) > antal) cycle + start(7,3), stopp(7,3)) + do an73 = start(7,3), stopp(7,3), steg(7,3) + antel(7,3) = an73 + antel(7,2) + if (antel(7,3) > antal) cycle do plus73 = min(an73,8), max(an73 - 6,0), & - -1 - ansats(7,3,1) = plus73 - ansats(7,3,0) = an73 - plus73 + -1 + ansats(7,3,1) = plus73 + ansats(7,3,0) = an73 - plus73 ! 7g call slug (7, 4, varmax, varupp, varned, & ansats, org, lock(7,4), dubbel, low, & - start(7,4), stopp(7,4)) - do an74 = start(7,4), stopp(7,4), steg(7,4) - antel(7,4) = an74 + antel(7,3) - if (antel(7,4) > antal) cycle + start(7,4), stopp(7,4)) + do an74 = start(7,4), stopp(7,4), steg(7,4) + antel(7,4) = an74 + antel(7,3) + if (antel(7,4) > antal) cycle do plus74 = min(an74,10), max(an74 - 8,0), & - -1 - ansats(7,4,1) = plus74 - ansats(7,4,0) = an74 - plus74 + -1 + ansats(7,4,1) = plus74 + ansats(7,4,0) = an74 - plus74 ! 7h call slug (7, 5, varmax, varupp, varned, & ansats, org, lock(7,5), dubbel, low, & - start(7,5), stopp(7,5)) - do an75 = start(7,5), stopp(7,5), steg(7,5) - antel(7,5) = an75 + antel(7,4) + start(7,5), stopp(7,5)) + do an75 = start(7,5), stopp(7,5), steg(7,5) + antel(7,5) = an75 + antel(7,4) if (antel(7,5)>antal .or. ansats(7,4,1)>2) & - cycle + cycle do plus75 = min(an75,12), max(an75 - 10,0)& - , -1 - ansats(7,5,1) = plus75 - ansats(7,5,0) = an75 - plus75 + , -1 + ansats(7,5,1) = plus75 + ansats(7,5,0) = an75 - plus75 ! 7i call slug (7, 6, varmax, varupp, varned, & ansats, org, lock(7,6), dubbel, low, & - start(7,6), stopp(7,6)) - do an76 = start(7,6), stopp(7,6), steg(7,6) - antel(7,6) = an76 + antel(7,5) + start(7,6), stopp(7,6)) + do an76 = start(7,6), stopp(7,6), steg(7,6) + antel(7,6) = an76 + antel(7,5) if (.not.(antel(7,6)<=antal .and. ansats(7,& 5,1)<=2 .and. ansats(7,5,0)<=2 .and. & - antel(7,6)>=lim(7))) cycle + antel(7,6)>=lim(7))) cycle do plus76 = min(an76,14), max(an76 - 12,0)& - , -1 - ansats(7,6,1) = plus76 - ansats(7,6,0) = an76 - plus76 + , -1 + ansats(7,6,1) = plus76 + ansats(7,6,0) = an76 - plus76 ! 8s call slug (8, 0, varmax, varupp, varned, & ansats, org, lock(8,0), dubbel, low, & - start(8,0), stopp(8,0)) - do an80 = start(8,0), stopp(8,0), steg(8,0) - antel(8,0) = an80 + antel(7,6) + start(8,0), stopp(8,0)) + do an80 = start(8,0), stopp(8,0), steg(8,0) + antel(8,0) = an80 + antel(7,6) if (.not.(antel(8,0)<=antal .and. ansats(7,& - 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle - ansats(8,0,0) = an80 + 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle + ansats(8,0,0) = an80 ! 8p call slug (8, 1, varmax, varupp, varned, & ansats, org, lock(8,1), dubbel, low, & - start(8,1), stopp(8,1)) - do an81 = start(8,1), stopp(8,1), steg(8,1) - antel(8,1) = an81 + antel(8,0) - if (antel(8,1) > antal) cycle + start(8,1), stopp(8,1)) + do an81 = start(8,1), stopp(8,1), steg(8,1) + antel(8,1) = an81 + antel(8,0) + if (antel(8,1) > antal) cycle do plus81 = min(an81,4), max(an81 - 2,0), & - -1 - ansats(8,1,1) = plus81 - ansats(8,1,0) = an81 - plus81 + -1 + ansats(8,1,1) = plus81 + ansats(8,1,0) = an81 - plus81 ! 8d call slug (8, 2, varmax, varupp, varned, & ansats, org, lock(8,2), dubbel, low, & - start(8,2), stopp(8,2)) - do an82 = start(8,2), stopp(8,2), steg(8,2) - antel(8,2) = an82 + antel(8,1) - if (antel(8,2) > antal) cycle + start(8,2), stopp(8,2)) + do an82 = start(8,2), stopp(8,2), steg(8,2) + antel(8,2) = an82 + antel(8,1) + if (antel(8,2) > antal) cycle do plus82 = min(an82,6), max(an82 - 4,0), & - -1 - ansats(8,2,1) = plus82 - ansats(8,2,0) = an82 - plus82 + -1 + ansats(8,2,1) = plus82 + ansats(8,2,0) = an82 - plus82 ! 8f call slug (8, 3, varmax, varupp, varned, & ansats, org, lock(8,3), dubbel, low, & - start(8,3), stopp(8,3)) - do an83 = start(8,3), stopp(8,3), steg(8,3) - antel(8,3) = an83 + antel(8,2) - if (antel(8,3) > antal) cycle + start(8,3), stopp(8,3)) + do an83 = start(8,3), stopp(8,3), steg(8,3) + antel(8,3) = an83 + antel(8,2) + if (antel(8,3) > antal) cycle do plus83 = min(an83,8), max(an83 - 6,0), & - -1 - ansats(8,3,1) = plus83 - ansats(8,3,0) = an83 - plus83 + -1 + ansats(8,3,1) = plus83 + ansats(8,3,0) = an83 - plus83 ! 8g call slug (8, 4, varmax, varupp, varned, & ansats, org, lock(8,4), dubbel, low, & - start(8,4), stopp(8,4)) - - do an84 = start(8,4), stopp(8,4), steg(8,4) - antel(8,4) = an84 + antel(8,3) - if (antel(8,4) > antal) cycle + start(8,4), stopp(8,4)) + + do an84 = start(8,4), stopp(8,4), steg(8,4) + antel(8,4) = an84 + antel(8,3) + if (antel(8,4) > antal) cycle do plus84 = min(an84,10), max(an84 - 8,0), & - -1 - ansats(8,4,1) = plus84 - ansats(8,4,0) = an84 - plus84 + -1 + ansats(8,4,1) = plus84 + ansats(8,4,0) = an84 - plus84 ! 8h call slug (8, 5, varmax, varupp, varned, & ansats, org, lock(8,5), dubbel, low, & - start(8,5), stopp(8,5)) - do an85 = start(8,5), stopp(8,5), steg(8,5) - antel(8,5) = an85 + antel(8,4) + start(8,5), stopp(8,5)) + do an85 = start(8,5), stopp(8,5), steg(8,5) + antel(8,5) = an85 + antel(8,4) if (antel(8,5)>antal .or. ansats(8,4,1)>2) & - cycle + cycle do plus85 = min(an85,12), max(an85 - 10,0)& - , -1 - ansats(8,5,1) = plus85 - ansats(8,5,0) = an85 - plus85 + , -1 + ansats(8,5,1) = plus85 + ansats(8,5,0) = an85 - plus85 ! 8i call slug (8, 6, varmax, varupp, varned, & ansats, org, lock(8,6), dubbel, low, & - start(8,6), stopp(8,6)) - do an86 = start(8,6), stopp(8,6), steg(8,6) - antel(8,6) = an86 + antel(8,5) + start(8,6), stopp(8,6)) + do an86 = start(8,6), stopp(8,6), steg(8,6) + antel(8,6) = an86 + antel(8,5) if (.not.(antel(8,6)<=antal .and. ansats(8,& - 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle do plus86 = min(an86,14), max(an86 - 12,0)& - , -1 - ansats(8,6,1) = plus86 - ansats(8,6,0) = an86 - plus86 + , -1 + ansats(8,6,1) = plus86 + ansats(8,6,0) = an86 - plus86 ! 8k call slug (8, 7, varmax, varupp, varned, & ansats, org, lock(8,7), dubbel, low, & - start(8,7), stopp(8,7)) - do an87 = start(8,7), stopp(8,7), steg(8,7) - antel(8,7) = an87 + antel(8,6) + start(8,7), stopp(8,7)) + do an87 = start(8,7), stopp(8,7), steg(8,7) + antel(8,7) = an87 + antel(8,6) if (.not.(antel(8,7)<=antal .and. ansats(8,& 6,1)<=2 .and. ansats(8,6,0)<=2 .and. & - antel(8,7)>=lim(8))) cycle + antel(8,7)>=lim(8))) cycle do plus87 = min(an87,16), max(an87 - 14,0)& - , -1 - ansats(8,7,1) = plus87 - ansats(8,7,0) = an87 - plus87 + , -1 + ansats(8,7,1) = plus87 + ansats(8,7,0) = an87 - plus87 ! 9s call slug (9, 0, varmax, varupp, varned, & ansats, org, lock(9,0), dubbel, low, & - start(9,0), stopp(9,0)) - do an90 = start(9,0), stopp(9,0), steg(9,0) - antel(9,0) = an90 + antel(8,7) + start(9,0), stopp(9,0)) + do an90 = start(9,0), stopp(9,0), steg(9,0) + antel(9,0) = an90 + antel(8,7) if (.not.(antel(9,0)<=antal .and. ansats(8,& - 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle - ansats(9,0,0) = an90 + 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle + ansats(9,0,0) = an90 ! 9p call slug (9, 1, varmax, varupp, varned, & ansats, org, lock(9,1), dubbel, low, & - start(9,1), stopp(9,1)) - do an91 = start(9,1), stopp(9,1), steg(9,1) - antel(9,1) = an91 + antel(9,0) - if (antel(9,1) > antal) cycle + start(9,1), stopp(9,1)) + do an91 = start(9,1), stopp(9,1), steg(9,1) + antel(9,1) = an91 + antel(9,0) + if (antel(9,1) > antal) cycle do plus91 = min(an91,4), max(an91 - 2,0), & - -1 - ansats(9,1,1) = plus91 - ansats(9,1,0) = an91 - plus91 + -1 + ansats(9,1,1) = plus91 + ansats(9,1,0) = an91 - plus91 ! 9d call slug (9, 2, varmax, varupp, varned, & ansats, org, lock(9,2), dubbel, low, & - start(9,2), stopp(9,2)) - do an92 = start(9,2), stopp(9,2), steg(9,2) - antel(9,2) = an92 + antel(9,1) - if (antel(9,2) > antal) cycle + start(9,2), stopp(9,2)) + do an92 = start(9,2), stopp(9,2), steg(9,2) + antel(9,2) = an92 + antel(9,1) + if (antel(9,2) > antal) cycle do plus92 = min(an92,6), max(an92 - 4,0), & - -1 - ansats(9,2,1) = plus92 - ansats(9,2,0) = an92 - plus92 + -1 + ansats(9,2,1) = plus92 + ansats(9,2,0) = an92 - plus92 ! 9f call slug (9, 3, varmax, varupp, varned, & ansats, org, lock(9,3), dubbel, low, & - start(9,3), stopp(9,3)) - do an93 = start(9,3), stopp(9,3), steg(9,3) - antel(9,3) = an93 + antel(9,2) - if (antel(9,3) > antal) cycle + start(9,3), stopp(9,3)) + do an93 = start(9,3), stopp(9,3), steg(9,3) + antel(9,3) = an93 + antel(9,2) + if (antel(9,3) > antal) cycle do plus93 = min(an93,8), max(an93 - 6,0), & - -1 - ansats(9,3,1) = plus93 - ansats(9,3,0) = an93 - plus93 + -1 + ansats(9,3,1) = plus93 + ansats(9,3,0) = an93 - plus93 ! 9g call slug (9, 4, varmax, varupp, varned, & ansats, org, lock(9,4), dubbel, low, & - start(9,4), stopp(9,4)) - do an94 = start(9,4), stopp(9,4), steg(9,4) - antel(9,4) = an94 + antel(9,3) - if (antel(9,4) > antal) cycle + start(9,4), stopp(9,4)) + do an94 = start(9,4), stopp(9,4), steg(9,4) + antel(9,4) = an94 + antel(9,3) + if (antel(9,4) > antal) cycle do plus94 = min(an94,10), max(an94 - 8,0), & - -1 - ansats(9,4,1) = plus94 - ansats(9,4,0) = an94 - plus94 + -1 + ansats(9,4,1) = plus94 + ansats(9,4,0) = an94 - plus94 ! 9h call slug (9, 5, varmax, varupp, varned, & ansats, org, lock(9,5), dubbel, low, & - start(9,5), stopp(9,5)) - do an95 = start(9,5), stopp(9,5), steg(9,5) - antel(9,5) = an95 + antel(9,4) + start(9,5), stopp(9,5)) + do an95 = start(9,5), stopp(9,5), steg(9,5) + antel(9,5) = an95 + antel(9,4) if (antel(9,5)>antal .or. ansats(9,4,1)>2) & - cycle + cycle do plus95 = min(an95,12), max(an95 - 10,0)& - , -1 - ansats(9,5,1) = plus95 - ansats(9,5,0) = an95 - plus95 + , -1 + ansats(9,5,1) = plus95 + ansats(9,5,0) = an95 - plus95 ! 9i call slug (9, 6, varmax, varupp, varned, & ansats, org, lock(9,6), dubbel, low, & - start(9,6), stopp(9,6)) - do an96 = start(9,6), stopp(9,6), steg(9,6) - antel(9,6) = an96 + antel(9,5) + start(9,6), stopp(9,6)) + do an96 = start(9,6), stopp(9,6), steg(9,6) + antel(9,6) = an96 + antel(9,5) if (.not.(antel(9,6)<=antal .and. ansats(9,& - 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle do plus96 = min(an96,14), max(an96 - 12,0)& - , -1 - ansats(9,6,1) = plus96 - ansats(9,6,0) = an96 - plus96 + , -1 + ansats(9,6,1) = plus96 + ansats(9,6,0) = an96 - plus96 ! 9k call slug (9, 7, varmax, varupp, varned, & ansats, org, lock(9,7), dubbel, low, & - start(9,7), stopp(9,7)) - do an97 = start(9,7), stopp(9,7), steg(9,7) - antel(9,7) = an97 + antel(9,6) + start(9,7), stopp(9,7)) + do an97 = start(9,7), stopp(9,7), steg(9,7) + antel(9,7) = an97 + antel(9,6) if (.not.(antel(9,7)<=antal .and. ansats(9,& - 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle + 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle do plus97 = min(an97,16), max(an97 - 14,0)& - , -1 - ansats(9,7,1) = plus97 - ansats(9,7,0) = an97 - plus97 + , -1 + ansats(9,7,1) = plus97 + ansats(9,7,0) = an97 - plus97 ! 9l call slug (9, 8, varmax, varupp, varned, & ansats, org, lock(9,8), dubbel, low, & - start(9,8), stopp(9,8)) - do an98 = start(9,8), stopp(9,8), steg(9,8) - antel(9,8) = an98 + antel(9,7) + start(9,8), stopp(9,8)) + do an98 = start(9,8), stopp(9,8), steg(9,8) + antel(9,8) = an98 + antel(9,7) if (.not.(antel(9,8)<=antal .and. ansats(9,& 7,1)<=2 .and. ansats(9,7,0)<=2 .and. & - antel(9,8)>=lim(9))) cycle + antel(9,8)>=lim(9))) cycle do plus98 = min(an98,18), max(an98 - 16,0)& - , -1 - ansats(9,8,1) = plus98 - ansats(9,8,0) = an98 - plus98 + , -1 + ansats(9,8,1) = plus98 + ansats(9,8,0) = an98 - plus98 ! 10s call slug (10, 0, varmax, varupp, varned, & ansats, org, lock(10,0), dubbel, low, & - start(10,0), stopp(10,0)) + start(10,0), stopp(10,0)) do ana0 = start(10,0), stopp(10,0), steg(10& - ,0) - antel(10,0) = ana0 + antel(9,8) + ,0) + antel(10,0) = ana0 + antel(9,8) if (.not.(antel(10,0)<=antal .and. ansats(9& - ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle - ansats(10,0,0) = ana0 + ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle + ansats(10,0,0) = ana0 ! 10p call slug (10, 1, varmax, varupp, varned, & ansats, org, lock(10,1), dubbel, low, & - start(10,1), stopp(10,1)) + start(10,1), stopp(10,1)) do ana1 = start(10,1), stopp(10,1), steg(10& - ,1) - antel(10,1) = ana1 + antel(10,0) - if (antel(10,1) > antal) cycle + ,1) + antel(10,1) = ana1 + antel(10,0) + if (antel(10,1) > antal) cycle do plusa1 = min(ana1,4), max(ana1 - 2,0), & - -1 - ansats(10,1,1) = plusa1 - ansats(10,1,0) = ana1 - plusa1 + -1 + ansats(10,1,1) = plusa1 + ansats(10,1,0) = ana1 - plusa1 ! 10d call slug (10, 2, varmax, varupp, varned, & ansats, org, lock(10,2), dubbel, low, & - start(10,2), stopp(10,2)) + start(10,2), stopp(10,2)) do ana2 = start(10,2), stopp(10,2), steg(10& - ,2) - antel(10,2) = ana2 + antel(10,1) - if (antel(10,2) > antal) cycle + ,2) + antel(10,2) = ana2 + antel(10,1) + if (antel(10,2) > antal) cycle do plusa2 = min(ana2,6), max(ana2 - 4,0), & - -1 - ansats(10,2,1) = plusa2 - ansats(10,2,0) = ana2 - plusa2 + -1 + ansats(10,2,1) = plusa2 + ansats(10,2,0) = ana2 - plusa2 ! 10f call slug (10, 3, varmax, varupp, varned, & ansats, org, lock(10,3), dubbel, low, & - start(10,3), stopp(10,3)) + start(10,3), stopp(10,3)) do ana3 = start(10,3), stopp(10,3), steg(10& - ,3) - antel(10,3) = ana3 + antel(10,2) - if (antel(10,3) > antal) cycle + ,3) + antel(10,3) = ana3 + antel(10,2) + if (antel(10,3) > antal) cycle do plusa3 = min(ana3,8), max(ana3 - 6,0), & - -1 - ansats(10,3,1) = plusa3 - ansats(10,3,0) = ana3 - plusa3 + -1 + ansats(10,3,1) = plusa3 + ansats(10,3,0) = ana3 - plusa3 ! 10g call slug (10, 4, varmax, varupp, varned, & ansats, org, lock(10,4), dubbel, low, & - start(10,4), stopp(10,4)) + start(10,4), stopp(10,4)) do ana4 = start(10,4), stopp(10,4), steg(10& - ,4) - antel(10,4) = ana4 + antel(10,3) - if (antel(10,4) > antal) cycle + ,4) + antel(10,4) = ana4 + antel(10,3) + if (antel(10,4) > antal) cycle do plusa4 = min(ana4,10), max(ana4 - 8,0), & - -1 - ansats(10,4,1) = plusa4 - ansats(10,4,0) = ana4 - plusa4 + -1 + ansats(10,4,1) = plusa4 + ansats(10,4,0) = ana4 - plusa4 ! 10h call slug (10, 5, varmax, varupp, varned, & ansats, org, lock(10,5), dubbel, low, & - start(10,5), stopp(10,5)) + start(10,5), stopp(10,5)) do ana5 = start(10,5), stopp(10,5), steg(10& - ,5) - antel(10,5) = ana5 + antel(10,4) + ,5) + antel(10,5) = ana5 + antel(10,4) if (antel(10,5)>antal .or. ansats(10,4,1)>2& - ) cycle + ) cycle do plusa5 = min(ana5,12), max(ana5 - 10,0)& - , -1 - ansats(10,5,1) = plusa5 - ansats(10,5,0) = ana5 - plusa5 + , -1 + ansats(10,5,1) = plusa5 + ansats(10,5,0) = ana5 - plusa5 ! 10i call slug (10, 6, varmax, varupp, varned, & ansats, org, lock(10,6), dubbel, low, & - start(10,6), stopp(10,6)) + start(10,6), stopp(10,6)) do ana6 = start(10,6), stopp(10,6), steg(10& - ,6) - antel(10,6) = ana6 + antel(10,5) + ,6) + antel(10,6) = ana6 + antel(10,5) if (.not.(antel(10,6)<=antal .and. ansats(& 10,5,1)<=2 .and. ansats(10,5,0)<=2)) & - cycle + cycle do plusa6 = min(ana6,14), max(ana6 - 12,0)& - , -1 - ansats(10,6,1) = plusa6 - ansats(10,6,0) = ana6 - plusa6 + , -1 + ansats(10,6,1) = plusa6 + ansats(10,6,0) = ana6 - plusa6 ! 10k call slug (10, 7, varmax, varupp, varned, & ansats, org, lock(10,7), dubbel, low, & - start(10,7), stopp(10,7)) + start(10,7), stopp(10,7)) do ana7 = start(10,7), stopp(10,7), steg(10& - ,7) - antel(10,7) = ana7 + antel(10,6) + ,7) + antel(10,7) = ana7 + antel(10,6) if (.not.(antel(10,7)<=antal .and. ansats(& 10,6,1)<=2 .and. ansats(10,6,0)<=2)) & - cycle + cycle do plusa7 = min(ana7,16), max(ana7 - 14,0)& - , -1 - ansats(10,7,1) = plusa7 - ansats(10,7,0) = ana7 - plusa7 + , -1 + ansats(10,7,1) = plusa7 + ansats(10,7,0) = ana7 - plusa7 ! 10l call slug (10, 8, varmax, varupp, varned, & ansats, org, lock(10,8), dubbel, low, & - start(10,8), stopp(10,8)) + start(10,8), stopp(10,8)) do ana8 = start(10,8), stopp(10,8), steg(10& - ,8) - antel(10,8) = ana8 + antel(10,7) + ,8) + antel(10,8) = ana8 + antel(10,7) if (.not.(antel(10,8)<=antal .and. ansats(& 10,7,1)<=2 .and. ansats(10,7,0)<=2)) & - cycle + cycle do plusa8 = min(ana8,18), max(ana8 - 16,0)& - , -1 - ansats(10,8,1) = plusa8 - ansats(10,8,0) = ana8 - plusa8 + , -1 + ansats(10,8,1) = plusa8 + ansats(10,8,0) = ana8 - plusa8 ! 10m call slug (10, 9, varmax, varupp, varned, & ansats, org, lock(10,9), dubbel, low, & - start(10,9), stopp(10,9)) + start(10,9), stopp(10,9)) do ana9 = start(10,9), stopp(10,9), steg(10& - ,9) - antel(10,9) = ana9 + antel(10,8) + ,9) + antel(10,9) = ana9 + antel(10,8) if (.not.(antel(10,9)<=antal .and. ansats(& 10,8,1)<=2 .and. ansats(10,8,0)<=2& - .and. antel(10,9)>=lim(10))) cycle + .and. antel(10,9)>=lim(10))) cycle do plusa9 = min(ana9,20), max(ana9 - 18,0)& - , -1 - ansats(10,9,1) = plusa9 - ansats(10,9,0) = ana9 - plusa9 + , -1 + ansats(10,9,1) = plusa9 + ansats(10,9,0) = ana9 - plusa9 ! 11s call slug (11, 0, varmax, varupp, varned, & ansats, org, lock(11,0), dubbel, low, & - start(11,0), stopp(11,0)) + start(11,0), stopp(11,0)) do anb0 = start(11,0), stopp(11,0), steg(11& - ,0) - antel(11,0) = anb0 + antel(10,9) + ,0) + antel(11,0) = anb0 + antel(10,9) if (.not.(antel(11,0)<=antal .and. ansats(& 10,9,1)<=2 .and. ansats(10,9,0)<=2)) & - cycle - ansats(11,0,0) = anb0 + cycle + ansats(11,0,0) = anb0 ! 11p call slug (11, 1, varmax, varupp, varned, & ansats, org, lock(11,1), dubbel, low, & - start(11,1), stopp(11,1)) + start(11,1), stopp(11,1)) do anb1 = start(11,1), stopp(11,1), steg(11& - ,1) - antel(11,1) = anb1 + antel(11,0) - if (antel(11,1) > antal) cycle + ,1) + antel(11,1) = anb1 + antel(11,0) + if (antel(11,1) > antal) cycle do plusb1 = min(anb1,4), max(anb1 - 2,0), & - -1 - ansats(11,1,1) = plusb1 - ansats(11,1,0) = anb1 - plusb1 + -1 + ansats(11,1,1) = plusb1 + ansats(11,1,0) = anb1 - plusb1 ! 11d call slug (11, 2, varmax, varupp, varned, & ansats, org, lock(11,2), dubbel, low, & - start(11,2), stopp(11,2)) + start(11,2), stopp(11,2)) do anb2 = start(11,2), stopp(11,2), steg(11& - ,2) - antel(11,2) = anb2 + antel(11,1) - if (antel(11,2) > antal) cycle + ,2) + antel(11,2) = anb2 + antel(11,1) + if (antel(11,2) > antal) cycle do plusb2 = min(anb2,6), max(anb2 - 4,0), & - -1 - ansats(11,2,1) = plusb2 - ansats(11,2,0) = anb2 - plusb2 + -1 + ansats(11,2,1) = plusb2 + ansats(11,2,0) = anb2 - plusb2 ! 11f call slug (11, 3, varmax, varupp, varned, & ansats, org, lock(11,3), dubbel, low, & - start(11,3), stopp(11,3)) + start(11,3), stopp(11,3)) do anb3 = start(11,3), stopp(11,3), steg(11& - ,3) - antel(11,3) = anb3 + antel(11,2) - if (antel(11,3) > antal) cycle + ,3) + antel(11,3) = anb3 + antel(11,2) + if (antel(11,3) > antal) cycle do plusb3 = min(anb3,8), max(anb3 - 6,0), & - -1 - ansats(11,3,1) = plusb3 - ansats(11,3,0) = anb3 - plusb3 + -1 + ansats(11,3,1) = plusb3 + ansats(11,3,0) = anb3 - plusb3 ! 11g call slug (11, 4, varmax, varupp, varned, & ansats, org, lock(11,4), dubbel, low, & - start(11,4), stopp(11,4)) + start(11,4), stopp(11,4)) do anb4 = start(11,4), stopp(11,4), steg(11& - ,4) - antel(11,4) = anb4 + antel(11,3) - if (antel(11,4) > antal) cycle + ,4) + antel(11,4) = anb4 + antel(11,3) + if (antel(11,4) > antal) cycle do plusb4 = min(anb4,10), max(anb4 - 8,0), & - -1 - ansats(11,4,1) = plusb4 - ansats(11,4,0) = anb4 - plusb4 + -1 + ansats(11,4,1) = plusb4 + ansats(11,4,0) = anb4 - plusb4 ! 11h call slug (11, 5, varmax, varupp, varned, & ansats, org, lock(11,5), dubbel, low, & - start(11,5), stopp(11,5)) + start(11,5), stopp(11,5)) do anb5 = start(11,5), stopp(11,5), steg(11& - ,5) - antel(11,5) = anb5 + antel(11,4) + ,5) + antel(11,5) = anb5 + antel(11,4) if (antel(11,5)>antal .or. ansats(11,4,1)>2& - ) cycle + ) cycle do plusb5 = min(anb5,12), max(anb5 - 10,0)& - , -1 - ansats(11,5,1) = plusb5 - ansats(11,5,0) = anb5 - plusb5 + , -1 + ansats(11,5,1) = plusb5 + ansats(11,5,0) = anb5 - plusb5 ! 11i call slug (11, 6, varmax, varupp, varned, & ansats, org, lock(11,6), dubbel, low, & - start(11,6), stopp(11,6)) + start(11,6), stopp(11,6)) do anb6 = start(11,6), stopp(11,6), steg(11& - ,6) - antel(11,6) = anb6 + antel(11,5) + ,6) + antel(11,6) = anb6 + antel(11,5) if (.not.(antel(11,6)<=antal .and. ansats(& 11,5,1)<=2 .and. ansats(11,5,0)<=2)) & - cycle + cycle do plusb6 = min(anb6,14), max(anb6 - 12,0)& - , -1 - ansats(11,6,1) = plusb6 - ansats(11,6,0) = anb6 - plusb6 + , -1 + ansats(11,6,1) = plusb6 + ansats(11,6,0) = anb6 - plusb6 ! 11k call slug (11, 7, varmax, varupp, varned, & ansats, org, lock(11,7), dubbel, low, & - start(11,7), stopp(11,7)) + start(11,7), stopp(11,7)) do anb7 = start(11,7), stopp(11,7), steg(11& - ,7) - antel(11,7) = anb7 + antel(11,6) + ,7) + antel(11,7) = anb7 + antel(11,6) if (.not.(antel(11,7)<=antal .and. ansats(& 11,6,1)<=2 .and. ansats(11,6,0)<=2)) & - cycle + cycle do plusb7 = min(anb7,16), max(anb7 - 14,0)& - , -1 - ansats(11,7,1) = plusb7 - ansats(11,7,0) = anb7 - plusb7 + , -1 + ansats(11,7,1) = plusb7 + ansats(11,7,0) = anb7 - plusb7 ! 11l call slug (11, 8, varmax, varupp, varned, & ansats, org, lock(11,8), dubbel, low, & - start(11,8), stopp(11,8)) + start(11,8), stopp(11,8)) do anb8 = start(11,8), stopp(11,8), steg(11& - ,8) - antel(11,8) = anb8 + antel(11,7) + ,8) + antel(11,8) = anb8 + antel(11,7) if (.not.(antel(11,8)<=antal .and. ansats(& 11,7,1)<=2 .and. ansats(11,7,0)<=2)) & - cycle + cycle do plusb8 = min(anb8,18), max(anb8 - 16,0)& - , -1 - ansats(11,8,1) = plusb8 - ansats(11,8,0) = anb8 - plusb8 + , -1 + ansats(11,8,1) = plusb8 + ansats(11,8,0) = anb8 - plusb8 ! 11m call slug (11, 9, varmax, varupp, varned, & ansats, org, lock(11,9), dubbel, low, & - start(11,9), stopp(11,9)) + start(11,9), stopp(11,9)) do anb9 = start(11,9), stopp(11,9), steg(11& - ,9) - antel(11,9) = anb9 + antel(11,8) + ,9) + antel(11,9) = anb9 + antel(11,8) if (.not.(antel(11,9)<=antal .and. ansats(& 11,8,1)<=2 .and. ansats(11,8,0)<=2)) & - cycle + cycle do plusb9 = min(anb9,20), max(anb9 - 18,0)& - , -1 - ansats(11,9,1) = plusb9 - ansats(11,9,0) = anb9 - plusb9 + , -1 + ansats(11,9,1) = plusb9 + ansats(11,9,0) = anb9 - plusb9 ! 11n call slug (11, 10, varmax, varupp, varned, & ansats, org, lock(11,10), dubbel, low, & - start(11,10), stopp(11,10)) + start(11,10), stopp(11,10)) do anba = start(11,10), stopp(11,10), steg(& - 11,10) - antel(11,10) = anba + antel(11,9) + 11,10) + antel(11,10) = anba + antel(11,9) if (.not.(antel(11,10)<=antal .and. ansats(& 11,9,1)<=2 .and. ansats(11,9,0)<=2& - .and. antel(11,10)>=lim(11))) cycle + .and. antel(11,10)>=lim(11))) cycle do plusba = min(anba,22), max(anba - 20,0)& - , -1 - ansats(11,10,1) = plusba - ansats(11,10,0) = anba - plusba + , -1 + ansats(11,10,1) = plusba + ansats(11,10,0) = anba - plusba ! 12s call slug (12, 0, varmax, varupp, varned, & ansats, org, lock(12,0), dubbel, low, & - start(12,0), stopp(12,0)) + start(12,0), stopp(12,0)) do anc0 = start(12,0), stopp(12,0), steg(12& - ,0) - antel(12,0) = anc0 + antel(11,10) + ,0) + antel(12,0) = anc0 + antel(11,10) if (.not.(antel(12,0)<=antal .and. ansats(& 11,10,1)<=2 .and. ansats(11,10,0)<=2)) & - cycle - ansats(12,0,0) = anc0 + cycle + ansats(12,0,0) = anc0 ! 12p call slug (12, 1, varmax, varupp, varned, & ansats, org, lock(12,1), dubbel, low, & - start(12,1), stopp(12,1)) + start(12,1), stopp(12,1)) do anc1 = start(12,1), stopp(12,1), steg(12& - ,1) - antel(12,1) = anc1 + antel(12,0) - if (antel(12,1) > antal) cycle + ,1) + antel(12,1) = anc1 + antel(12,0) + if (antel(12,1) > antal) cycle do plusc1 = min(anc1,4), max(anc1 - 2,0), & - -1 - ansats(12,1,1) = plusc1 - ansats(12,1,0) = anc1 - plusc1 + -1 + ansats(12,1,1) = plusc1 + ansats(12,1,0) = anc1 - plusc1 ! 12d call slug (12, 2, varmax, varupp, varned, & ansats, org, lock(12,2), dubbel, low, & - start(12,2), stopp(12,2)) + start(12,2), stopp(12,2)) do anc2 = start(12,2), stopp(12,2), steg(12& - ,2) - antel(12,2) = anc2 + antel(12,1) - if (antel(12,2) > antal) cycle + ,2) + antel(12,2) = anc2 + antel(12,1) + if (antel(12,2) > antal) cycle do plusc2 = min(anc2,6), max(anc2 - 4,0), & - -1 - ansats(12,2,1) = plusc2 - ansats(12,2,0) = anc2 - plusc2 + -1 + ansats(12,2,1) = plusc2 + ansats(12,2,0) = anc2 - plusc2 ! 12f call slug (12, 3, varmax, varupp, varned, & ansats, org, lock(12,3), dubbel, low, & - start(12,3), stopp(12,3)) + start(12,3), stopp(12,3)) do anc3 = start(12,3), stopp(12,3), steg(12& - ,3) - antel(12,3) = anc3 + antel(12,2) - if (antel(12,3) > antal) cycle + ,3) + antel(12,3) = anc3 + antel(12,2) + if (antel(12,3) > antal) cycle do plusc3 = min(anc3,8), max(anc3 - 6,0), & - -1 - ansats(12,3,1) = plusc3 - ansats(12,3,0) = anc3 - plusc3 + -1 + ansats(12,3,1) = plusc3 + ansats(12,3,0) = anc3 - plusc3 ! 12g call slug (12, 4, varmax, varupp, varned, & ansats, org, lock(12,4), dubbel, low, & - start(12,4), stopp(12,4)) + start(12,4), stopp(12,4)) do anc4 = start(12,4), stopp(12,4), steg(12& - ,4) - antel(12,4) = anc4 + antel(12,3) - if (antel(12,4) > antal) cycle + ,4) + antel(12,4) = anc4 + antel(12,3) + if (antel(12,4) > antal) cycle do plusc4 = min(anc4,10), max(anc4 - 8,0), & - -1 - ansats(12,4,1) = plusc4 - ansats(12,4,0) = anc4 - plusc4 + -1 + ansats(12,4,1) = plusc4 + ansats(12,4,0) = anc4 - plusc4 ! 12h call slug (12, 5, varmax, varupp, varned, & ansats, org, lock(12,5), dubbel, low, & - start(12,5), stopp(12,5)) + start(12,5), stopp(12,5)) do anc5 = start(12,5), stopp(12,5), steg(12& - ,5) - antel(12,5) = anc5 + antel(12,4) + ,5) + antel(12,5) = anc5 + antel(12,4) if (antel(12,5)>antal .or. ansats(12,4,1)>2& - ) cycle + ) cycle do plusc5 = min(anc5,12), max(anc5 - 10,0)& - , -1 - ansats(12,5,1) = plusc5 - ansats(12,5,0) = anc5 - plusc5 + , -1 + ansats(12,5,1) = plusc5 + ansats(12,5,0) = anc5 - plusc5 ! 12i call slug (12, 6, varmax, varupp, varned, & ansats, org, lock(12,6), dubbel, low, & - start(12,6), stopp(12,6)) + start(12,6), stopp(12,6)) do anc6 = start(12,6), stopp(12,6), steg(12& - ,6) - antel(12,6) = anc6 + antel(12,5) + ,6) + antel(12,6) = anc6 + antel(12,5) if (.not.(antel(12,6)<=antal .and. ansats(& 12,5,1)<=2 .and. ansats(12,5,0)<=2)) & - cycle + cycle do plusc6 = min(anc6,14), max(anc6 - 12,0)& - , -1 - ansats(12,6,1) = plusc6 - ansats(12,6,0) = anc6 - plusc6 + , -1 + ansats(12,6,1) = plusc6 + ansats(12,6,0) = anc6 - plusc6 ! 12k call slug (12, 7, varmax, varupp, varned, & ansats, org, lock(12,7), dubbel, low, & - start(12,7), stopp(12,7)) + start(12,7), stopp(12,7)) do anc7 = start(12,7), stopp(12,7), steg(12& - ,7) - antel(12,7) = anc7 + antel(12,6) + ,7) + antel(12,7) = anc7 + antel(12,6) if (.not.(antel(12,7)<=antal .and. ansats(& 12,6,1)<=2 .and. ansats(12,6,0)<=2)) & - cycle + cycle do plusc7 = min(anc7,16), max(anc7 - 14,0)& - , -1 - ansats(12,7,1) = plusc7 - ansats(12,7,0) = anc7 - plusc7 + , -1 + ansats(12,7,1) = plusc7 + ansats(12,7,0) = anc7 - plusc7 ! 12l call slug (12, 8, varmax, varupp, varned, & ansats, org, lock(12,8), dubbel, low, & - start(12,8), stopp(12,8)) + start(12,8), stopp(12,8)) do anc8 = start(12,8), stopp(12,8), steg(12& - ,8) - antel(12,8) = anc8 + antel(12,7) + ,8) + antel(12,8) = anc8 + antel(12,7) if (.not.(antel(12,8)<=antal .and. ansats(& 12,7,1)<=2 .and. ansats(12,7,0)<=2)) & - cycle + cycle do plusc8 = min(anc8,18), max(anc8 - 16,0)& - , -1 - ansats(12,8,1) = plusc8 - ansats(12,8,0) = anc8 - plusc8 + , -1 + ansats(12,8,1) = plusc8 + ansats(12,8,0) = anc8 - plusc8 ! 12m call slug (12, 9, varmax, varupp, varned, & ansats, org, lock(12,9), dubbel, low, & - start(12,9), stopp(12,9)) + start(12,9), stopp(12,9)) do anc9 = start(12,9), stopp(12,9), steg(12& - ,9) - antel(12,9) = anc9 + antel(12,8) + ,9) + antel(12,9) = anc9 + antel(12,8) if (.not.(antel(12,9)<=antal .and. ansats(& 12,8,1)<=2 .and. ansats(12,8,0)<=2)) & - cycle + cycle do plusc9 = min(anc9,20), max(anc9 - 18,0)& - , -1 - ansats(12,9,1) = plusc9 - ansats(12,9,0) = anc9 - plusc9 + , -1 + ansats(12,9,1) = plusc9 + ansats(12,9,0) = anc9 - plusc9 ! 12n call slug (12, 10, varmax, varupp, varned, & ansats, org, lock(12,10), dubbel, low, & - start(12,10), stopp(12,10)) + start(12,10), stopp(12,10)) do anca = start(12,10), stopp(12,10), steg(& - 12,10) - antel(12,10) = anca + antel(12,9) + 12,10) + antel(12,10) = anca + antel(12,9) if (.not.(antel(12,10)<=antal .and. ansats(& 12,9,1)<=2 .and. ansats(12,9,0)<=2& - .and. antel(12,10)>=lim(12))) cycle + .and. antel(12,10)>=lim(12))) cycle do plusca = min(anca,22), max(anca - 20,0)& - , -1 - ansats(12,10,1) = plusca - ansats(12,10,0) = anca - plusca + , -1 + ansats(12,10,1) = plusca + ansats(12,10,0) = anca - plusca ! 13s call slug (13, 0, varmax, varupp, varned, & ansats, org, lock(13,0), dubbel, low, & - start(13,0), stopp(13,0)) + start(13,0), stopp(13,0)) do and0 = start(13,0), stopp(13,0), steg(13& - ,0) - antel(13,0) = and0 + antel(12,10) + ,0) + antel(13,0) = and0 + antel(12,10) if (.not.(antel(13,0)<=antal .and. ansats(& 12,10,1)<=2 .and. ansats(12,10,0)<=2)) & - cycle - ansats(13,0,0) = and0 + cycle + ansats(13,0,0) = and0 ! 13p call slug (13, 1, varmax, varupp, varned, & ansats, org, lock(13,1), dubbel, low, & - start(13,1), stopp(13,1)) + start(13,1), stopp(13,1)) do and1 = start(13,1), stopp(13,1), steg(13& - ,1) - antel(13,1) = and1 + antel(13,0) - if (antel(13,1) > antal) cycle + ,1) + antel(13,1) = and1 + antel(13,0) + if (antel(13,1) > antal) cycle do plusd1 = min(and1,4), max(and1 - 2,0), & - -1 - ansats(13,1,1) = plusd1 - ansats(13,1,0) = and1 - plusd1 + -1 + ansats(13,1,1) = plusd1 + ansats(13,1,0) = and1 - plusd1 ! 13d call slug (13, 2, varmax, varupp, varned, & ansats, org, lock(13,2), dubbel, low, & - start(13,2), stopp(13,2)) + start(13,2), stopp(13,2)) do and2 = start(13,2), stopp(13,2), steg(13& - ,2) - antel(13,2) = and2 + antel(13,1) - if (antel(13,2) > antal) cycle + ,2) + antel(13,2) = and2 + antel(13,1) + if (antel(13,2) > antal) cycle do plusd2 = min(and2,6), max(and2 - 4,0), & - -1 - ansats(13,2,1) = plusd2 - ansats(13,2,0) = and2 - plusd2 + -1 + ansats(13,2,1) = plusd2 + ansats(13,2,0) = and2 - plusd2 ! 13f call slug (13, 3, varmax, varupp, varned, & ansats, org, lock(13,3), dubbel, low, & - start(13,3), stopp(13,3)) + start(13,3), stopp(13,3)) do and3 = start(13,3), stopp(13,3), steg(13& - ,3) - antel(13,3) = and3 + antel(13,2) - if (antel(13,3) > antal) cycle + ,3) + antel(13,3) = and3 + antel(13,2) + if (antel(13,3) > antal) cycle do plusd3 = min(and3,8), max(and3 - 6,0), & - -1 - ansats(13,3,1) = plusd3 - ansats(13,3,0) = and3 - plusd3 + -1 + ansats(13,3,1) = plusd3 + ansats(13,3,0) = and3 - plusd3 ! 13g call slug (13, 4, varmax, varupp, varned, & ansats, org, lock(13,4), dubbel, low, & - start(13,4), stopp(13,4)) + start(13,4), stopp(13,4)) do and4 = start(13,4), stopp(13,4), steg(13& - ,4) - antel(13,4) = and4 + antel(13,3) - if (antel(13,4) > antal) cycle + ,4) + antel(13,4) = and4 + antel(13,3) + if (antel(13,4) > antal) cycle do plusd4 = min(and4,10), max(and4 - 8,0), & - -1 - ansats(13,4,1) = plusd4 - ansats(13,4,0) = and4 - plusd4 + -1 + ansats(13,4,1) = plusd4 + ansats(13,4,0) = and4 - plusd4 ! 13h call slug (13, 5, varmax, varupp, varned, & ansats, org, lock(13,5), dubbel, low, & - start(13,5), stopp(13,5)) + start(13,5), stopp(13,5)) do and5 = start(13,5), stopp(13,5), steg(13& - ,5) - antel(13,5) = and5 + antel(13,4) + ,5) + antel(13,5) = and5 + antel(13,4) if (antel(13,5)>antal .or. ansats(13,4,1)>2& - ) cycle + ) cycle do plusd5 = min(and5,12), max(and5 - 10,0)& - , -1 - ansats(13,5,1) = plusd5 - ansats(13,5,0) = and5 - plusd5 + , -1 + ansats(13,5,1) = plusd5 + ansats(13,5,0) = and5 - plusd5 ! 13i call slug (13, 6, varmax, varupp, varned, & ansats, org, lock(13,6), dubbel, low, & - start(13,6), stopp(13,6)) + start(13,6), stopp(13,6)) do and6 = start(13,6), stopp(13,6), steg(13& - ,6) - antel(13,6) = and6 + antel(13,5) + ,6) + antel(13,6) = and6 + antel(13,5) if (.not.(antel(13,6)<=antal .and. ansats(& 13,5,1)<=2 .and. ansats(13,5,0)<=2)) & - cycle + cycle do plusd6 = min(and6,14), max(and6 - 12,0)& - , -1 - ansats(13,6,1) = plusd6 - ansats(13,6,0) = and6 - plusd6 + , -1 + ansats(13,6,1) = plusd6 + ansats(13,6,0) = and6 - plusd6 ! 13k call slug (13, 7, varmax, varupp, varned, & ansats, org, lock(13,7), dubbel, low, & - start(13,7), stopp(13,7)) + start(13,7), stopp(13,7)) do and7 = start(13,7), stopp(13,7), steg(13& - ,7) - antel(13,7) = and7 + antel(13,6) + ,7) + antel(13,7) = and7 + antel(13,6) if (.not.(antel(13,7)<=antal .and. ansats(& 13,6,1)<=2 .and. ansats(13,6,0)<=2)) & - cycle + cycle do plusd7 = min(and7,16), max(and7 - 14,0)& - , -1 - ansats(13,7,1) = plusd7 - ansats(13,7,0) = and7 - plusd7 + , -1 + ansats(13,7,1) = plusd7 + ansats(13,7,0) = and7 - plusd7 ! 13l call slug (13, 8, varmax, varupp, varned, & ansats, org, lock(13,8), dubbel, low, & - start(13,8), stopp(13,8)) + start(13,8), stopp(13,8)) do and8 = start(13,8), stopp(13,8), steg(13& - ,8) - antel(13,8) = and8 + antel(13,7) + ,8) + antel(13,8) = and8 + antel(13,7) if (.not.(antel(13,8)<=antal .and. ansats(& 13,7,1)<=2 .and. ansats(13,7,0)<=2)) & - cycle + cycle do plusd8 = min(and8,18), max(and8 - 16,0)& - , -1 - ansats(13,8,1) = plusd8 - ansats(13,8,0) = and8 - plusd8 + , -1 + ansats(13,8,1) = plusd8 + ansats(13,8,0) = and8 - plusd8 ! 13m call slug (13, 9, varmax, varupp, varned, & ansats, org, lock(13,9), dubbel, low, & - start(13,9), stopp(13,9)) + start(13,9), stopp(13,9)) do and9 = start(13,9), stopp(13,9), steg(13& - ,9) - antel(13,9) = and9 + antel(13,8) + ,9) + antel(13,9) = and9 + antel(13,8) if (.not.(antel(13,9)<=antal .and. ansats(& 13,8,1)<=2 .and. ansats(13,8,0)<=2)) & - cycle + cycle do plusd9 = min(and9,20), max(and9 - 18,0)& - , -1 - ansats(13,9,1) = plusd9 - ansats(13,9,0) = and9 - plusd9 + , -1 + ansats(13,9,1) = plusd9 + ansats(13,9,0) = and9 - plusd9 ! 13n call slug (13, 10, varmax, varupp, varned, & ansats, org, lock(13,10), dubbel, low, & - start(13,10), stopp(13,10)) + start(13,10), stopp(13,10)) do anda = start(13,10), stopp(13,10), steg(& - 13,10) - antel(13,10) = anda + antel(13,9) + 13,10) + antel(13,10) = anda + antel(13,9) if (.not.(antel(13,10)<=antal .and. ansats(& 13,9,1)<=2 .and. ansats(13,9,0)<=2& - .and. antel(13,10)>=lim(13))) cycle + .and. antel(13,10)>=lim(13))) cycle do plusda = min(anda,22), max(anda - 20,0)& - , -1 - ansats(13,10,1) = plusda - ansats(13,10,0) = anda - plusda + , -1 + ansats(13,10,1) = plusda + ansats(13,10,0) = anda - plusda ! 14s call slug (14, 0, varmax, varupp, varned, & ansats, org, lock(14,0), dubbel, low, & - start(14,0), stopp(14,0)) + start(14,0), stopp(14,0)) do ane0 = start(14,0), stopp(14,0), steg(14& - ,0) - antel(14,0) = ane0 + antel(13,10) + ,0) + antel(14,0) = ane0 + antel(13,10) if (.not.(antel(14,0)<=antal .and. ansats(& 13,10,1)<=2 .and. ansats(13,10,0)<=2)) & - cycle - ansats(14,0,0) = ane0 + cycle + ansats(14,0,0) = ane0 ! 14p call slug (14, 1, varmax, varupp, varned, & ansats, org, lock(14,1), dubbel, low, & - start(14,1), stopp(14,1)) + start(14,1), stopp(14,1)) do ane1 = start(14,1), stopp(14,1), steg(14& - ,1) - antel(14,1) = ane1 + antel(14,0) - if (antel(14,1) > antal) cycle + ,1) + antel(14,1) = ane1 + antel(14,0) + if (antel(14,1) > antal) cycle do pluse1 = min(ane1,4), max(ane1 - 2,0), & - -1 - ansats(14,1,1) = pluse1 - ansats(14,1,0) = ane1 - pluse1 + -1 + ansats(14,1,1) = pluse1 + ansats(14,1,0) = ane1 - pluse1 ! 14d call slug (14, 2, varmax, varupp, varned, & ansats, org, lock(14,2), dubbel, low, & - start(14,2), stopp(14,2)) + start(14,2), stopp(14,2)) do ane2 = start(14,2), stopp(14,2), steg(14& - ,2) - antel(14,2) = ane2 + antel(14,1) - if (antel(14,2) > antal) cycle + ,2) + antel(14,2) = ane2 + antel(14,1) + if (antel(14,2) > antal) cycle do pluse2 = min(ane2,6), max(ane2 - 4,0), & - -1 - ansats(14,2,1) = pluse2 - ansats(14,2,0) = ane2 - pluse2 + -1 + ansats(14,2,1) = pluse2 + ansats(14,2,0) = ane2 - pluse2 ! 14f call slug (14, 3, varmax, varupp, varned, & ansats, org, lock(14,3), dubbel, low, & - start(14,3), stopp(14,3)) + start(14,3), stopp(14,3)) do ane3 = start(14,3), stopp(14,3), steg(14& - ,3) - antel(14,3) = ane3 + antel(14,2) - if (antel(14,3) > antal) cycle + ,3) + antel(14,3) = ane3 + antel(14,2) + if (antel(14,3) > antal) cycle do pluse3 = min(ane3,8), max(ane3 - 6,0), & - -1 - ansats(14,3,1) = pluse3 - ansats(14,3,0) = ane3 - pluse3 + -1 + ansats(14,3,1) = pluse3 + ansats(14,3,0) = ane3 - pluse3 ! 14g call slug (14, 4, varmax, varupp, varned, & ansats, org, lock(14,4), dubbel, low, & - start(14,4), stopp(14,4)) + start(14,4), stopp(14,4)) do ane4 = start(14,4), stopp(14,4), steg(14& - ,4) - antel(14,4) = ane4 + antel(14,3) - if (antel(14,4) > antal) cycle + ,4) + antel(14,4) = ane4 + antel(14,3) + if (antel(14,4) > antal) cycle do pluse4 = min(ane4,10), max(ane4 - 8,0), & - -1 - ansats(14,4,1) = pluse4 - ansats(14,4,0) = ane4 - pluse4 + -1 + ansats(14,4,1) = pluse4 + ansats(14,4,0) = ane4 - pluse4 ! 14h call slug (14, 5, varmax, varupp, varned, & ansats, org, lock(14,5), dubbel, low, & - start(14,5), stopp(14,5)) + start(14,5), stopp(14,5)) do ane5 = start(14,5), stopp(14,5), steg(14& - ,5) - antel(14,5) = ane5 + antel(14,4) + ,5) + antel(14,5) = ane5 + antel(14,4) if (antel(14,5)>antal .or. ansats(14,4,1)>2& - ) cycle + ) cycle do pluse5 = min(ane5,12), max(ane5 - 10,0)& - , -1 - ansats(14,5,1) = pluse5 - ansats(14,5,0) = ane5 - pluse5 + , -1 + ansats(14,5,1) = pluse5 + ansats(14,5,0) = ane5 - pluse5 ! 14i call slug (14, 6, varmax, varupp, varned, & ansats, org, lock(14,6), dubbel, low, & - start(14,6), stopp(14,6)) + start(14,6), stopp(14,6)) do ane6 = start(14,6), stopp(14,6), steg(14& - ,6) - antel(14,6) = ane6 + antel(14,5) + ,6) + antel(14,6) = ane6 + antel(14,5) if (.not.(antel(14,6)<=antal .and. ansats(& 14,5,1)<=2 .and. ansats(14,5,0)<=2)) & - cycle + cycle do pluse6 = min(ane6,14), max(ane6 - 12,0)& - , -1 - ansats(14,6,1) = pluse6 - ansats(14,6,0) = ane6 - pluse6 + , -1 + ansats(14,6,1) = pluse6 + ansats(14,6,0) = ane6 - pluse6 ! 14k call slug (14, 7, varmax, varupp, varned, & ansats, org, lock(14,7), dubbel, low, & - start(14,7), stopp(14,7)) + start(14,7), stopp(14,7)) do ane7 = start(14,7), stopp(14,7), steg(14& - ,7) - antel(14,7) = ane7 + antel(14,6) + ,7) + antel(14,7) = ane7 + antel(14,6) if (.not.(antel(14,7)<=antal .and. ansats(& 14,6,1)<=2 .and. ansats(14,6,0)<=2)) & - cycle + cycle do pluse7 = min(ane7,16), max(ane7 - 14,0)& - , -1 - ansats(14,7,1) = pluse7 - ansats(14,7,0) = ane7 - pluse7 + , -1 + ansats(14,7,1) = pluse7 + ansats(14,7,0) = ane7 - pluse7 ! 14l call slug (14, 8, varmax, varupp, varned, & ansats, org, lock(14,8), dubbel, low, & - start(14,8), stopp(14,8)) + start(14,8), stopp(14,8)) do ane8 = start(14,8), stopp(14,8), steg(14& - ,8) - antel(14,8) = ane8 + antel(14,7) + ,8) + antel(14,8) = ane8 + antel(14,7) if (.not.(antel(14,8)<=antal .and. ansats(& 14,7,1)<=2 .and. ansats(14,7,0)<=2)) & - cycle + cycle do pluse8 = min(ane8,18), max(ane8 - 16,0)& - , -1 - ansats(14,8,1) = pluse8 - ansats(14,8,0) = ane8 - pluse8 + , -1 + ansats(14,8,1) = pluse8 + ansats(14,8,0) = ane8 - pluse8 ! 14m call slug (14, 9, varmax, varupp, varned, & ansats, org, lock(14,9), dubbel, low, & - start(14,9), stopp(14,9)) + start(14,9), stopp(14,9)) do ane9 = start(14,9), stopp(14,9), steg(14& - ,9) - antel(14,9) = ane9 + antel(14,8) + ,9) + antel(14,9) = ane9 + antel(14,8) if (.not.(antel(14,9)<=antal .and. ansats(& 14,8,1)<=2 .and. ansats(14,8,0)<=2)) & - cycle + cycle do pluse9 = min(ane9,20), max(ane9 - 18,0)& - , -1 - ansats(14,9,1) = pluse9 - ansats(14,9,0) = ane9 - pluse9 + , -1 + ansats(14,9,1) = pluse9 + ansats(14,9,0) = ane9 - pluse9 ! 14n call slug (14, 10, varmax, varupp, varned, & ansats, org, lock(14,10), dubbel, low, & - start(14,10), stopp(14,10)) + start(14,10), stopp(14,10)) do anea = start(14,10), stopp(14,10), steg(& - 14,10) - antel(14,10) = anea + antel(14,9) + 14,10) + antel(14,10) = anea + antel(14,9) if (.not.(antel(14,10)<=antal .and. ansats(& 14,9,1)<=2 .and. ansats(14,9,0)<=2& - .and. antel(14,10)>=lim(14))) cycle + .and. antel(14,10)>=lim(14))) cycle do plusea = min(anea,22), max(anea - 20,0)& - , -1 - ansats(14,10,1) = plusea - ansats(14,10,0) = anea - plusea + , -1 + ansats(14,10,1) = plusea + ansats(14,10,0) = anea - plusea ! 15s call slug (15, 0, varmax, varupp, varned, & ansats, org, lock(15,0), dubbel, low, & - start(15,0), stopp(15,0)) + start(15,0), stopp(15,0)) do anf0 = start(15,0), stopp(15,0), steg(15& - ,0) - antel(15,0) = anf0 + antel(14,10) + ,0) + antel(15,0) = anf0 + antel(14,10) if (.not.(antel(15,0)<=antal .and. ansats(& 14,10,1)<=2 .and. ansats(14,10,0)<=2)) & - cycle - ansats(15,0,0) = anf0 + cycle + ansats(15,0,0) = anf0 ! 15p call slug (15, 1, varmax, varupp, varned, & ansats, org, lock(15,1), dubbel, low, & - start(15,1), stopp(15,1)) + start(15,1), stopp(15,1)) do anf1 = start(15,1), stopp(15,1), steg(15& - ,1) - antel(15,1) = anf1 + antel(15,0) - if (antel(15,1) > antal) cycle + ,1) + antel(15,1) = anf1 + antel(15,0) + if (antel(15,1) > antal) cycle do plusf1 = min(anf1,4), max(anf1 - 2,0), & - -1 - ansats(15,1,1) = plusf1 - ansats(15,1,0) = anf1 - plusf1 + -1 + ansats(15,1,1) = plusf1 + ansats(15,1,0) = anf1 - plusf1 ! 15d call slug (15, 2, varmax, varupp, varned, & ansats, org, lock(15,2), dubbel, low, & - start(15,2), stopp(15,2)) + start(15,2), stopp(15,2)) do anf2 = start(15,2), stopp(15,2), steg(15& - ,2) - antel(15,2) = anf2 + antel(15,1) - if (antel(15,2) > antal) cycle + ,2) + antel(15,2) = anf2 + antel(15,1) + if (antel(15,2) > antal) cycle do plusf2 = min(anf2,6), max(anf2 - 4,0), & - -1 - ansats(15,2,1) = plusf2 - ansats(15,2,0) = anf2 - plusf2 + -1 + ansats(15,2,1) = plusf2 + ansats(15,2,0) = anf2 - plusf2 ! 15f call slug (15, 3, varmax, varupp, varned, & ansats, org, lock(15,3), dubbel, low, & - start(15,3), stopp(15,3)) + start(15,3), stopp(15,3)) do anf3 = start(15,3), stopp(15,3), steg(15& - ,3) - antel(15,3) = anf3 + antel(15,2) - if (antel(15,3) > antal) cycle + ,3) + antel(15,3) = anf3 + antel(15,2) + if (antel(15,3) > antal) cycle do plusf3 = min(anf3,8), max(anf3 - 6,0), & - -1 - ansats(15,3,1) = plusf3 - ansats(15,3,0) = anf3 - plusf3 + -1 + ansats(15,3,1) = plusf3 + ansats(15,3,0) = anf3 - plusf3 ! 15g call slug (15, 4, varmax, varupp, varned, & ansats, org, lock(15,4), dubbel, low, & - start(15,4), stopp(15,4)) + start(15,4), stopp(15,4)) do anf4 = start(15,4), stopp(15,4), steg(15& - ,4) - antel(15,4) = anf4 + antel(15,3) - if (antel(15,4) > antal) cycle + ,4) + antel(15,4) = anf4 + antel(15,3) + if (antel(15,4) > antal) cycle do plusf4 = min(anf4,10), max(anf4 - 8,0), & - -1 - ansats(15,4,1) = plusf4 - ansats(15,4,0) = anf4 - plusf4 + -1 + ansats(15,4,1) = plusf4 + ansats(15,4,0) = anf4 - plusf4 ! 15h call slug (15, 5, varmax, varupp, varned, & ansats, org, lock(15,5), dubbel, low, & - start(15,5), stopp(15,5)) + start(15,5), stopp(15,5)) do anf5 = start(15,5), stopp(15,5), steg(15& - ,5) - antel(15,5) = anf5 + antel(15,4) + ,5) + antel(15,5) = anf5 + antel(15,4) if (antel(15,5)>antal .or. ansats(15,4,1)>2& - ) cycle + ) cycle do plusf5 = min(anf5,12), max(anf5 - 10,0)& - , -1 - ansats(15,5,1) = plusf5 - ansats(15,5,0) = anf5 - plusf5 + , -1 + ansats(15,5,1) = plusf5 + ansats(15,5,0) = anf5 - plusf5 ! 15i call slug (15, 6, varmax, varupp, varned, & ansats, org, lock(15,6), dubbel, low, & - start(15,6), stopp(15,6)) + start(15,6), stopp(15,6)) do anf6 = start(15,6), stopp(15,6), steg(15& - ,6) - antel(15,6) = anf6 + antel(15,5) + ,6) + antel(15,6) = anf6 + antel(15,5) if (.not.(antel(15,6)<=antal .and. ansats(& 15,5,1)<=2 .and. ansats(15,5,0)<=2)) & - cycle + cycle do plusf6 = min(anf6,14), max(anf6 - 12,0)& - , -1 - ansats(15,6,1) = plusf6 - ansats(15,6,0) = anf6 - plusf6 + , -1 + ansats(15,6,1) = plusf6 + ansats(15,6,0) = anf6 - plusf6 ! 15k call slug (15, 7, varmax, varupp, varned, & ansats, org, lock(15,7), dubbel, low, & - start(15,7), stopp(15,7)) + start(15,7), stopp(15,7)) do anf7 = start(15,7), stopp(15,7), steg(15& - ,7) - antel(15,7) = anf7 + antel(15,6) + ,7) + antel(15,7) = anf7 + antel(15,6) if (.not.(antel(15,7)<=antal .and. ansats(& 15,6,1)<=2 .and. ansats(15,6,0)<=2)) & - cycle + cycle do plusf7 = min(anf7,16), max(anf7 - 14,0)& - , -1 - ansats(15,7,1) = plusf7 - ansats(15,7,0) = anf7 - plusf7 + , -1 + ansats(15,7,1) = plusf7 + ansats(15,7,0) = anf7 - plusf7 ! 15l call slug (15, 8, varmax, varupp, varned, & ansats, org, lock(15,8), dubbel, low, & - start(15,8), stopp(15,8)) + start(15,8), stopp(15,8)) do anf8 = start(15,8), stopp(15,8), steg(15& - ,8) - antel(15,8) = anf8 + antel(15,7) + ,8) + antel(15,8) = anf8 + antel(15,7) if (.not.(antel(15,8)<=antal .and. ansats(& 15,7,1)<=2 .and. ansats(15,7,0)<=2)) & - cycle + cycle do plusf8 = min(anf8,18), max(anf8 - 16,0)& - , -1 - ansats(15,8,1) = plusf8 - ansats(15,8,0) = anf8 - plusf8 + , -1 + ansats(15,8,1) = plusf8 + ansats(15,8,0) = anf8 - plusf8 ! 15m call slug (15, 9, varmax, varupp, varned, & ansats, org, lock(15,9), dubbel, low, & - start(15,9), stopp(15,9)) + start(15,9), stopp(15,9)) do anf9 = start(15,9), stopp(15,9), steg(15& - ,9) - antel(15,9) = anf9 + antel(15,8) + ,9) + antel(15,9) = anf9 + antel(15,8) if (.not.(antel(15,9)<=antal .and. ansats(& 15,8,1)<=2 .and. ansats(15,8,0)<=2)) & - cycle + cycle do plusf9 = min(anf9,20), max(anf9 - 18,0)& - , -1 - ansats(15,9,1) = plusf9 - ansats(15,9,0) = anf9 - plusf9 + , -1 + ansats(15,9,1) = plusf9 + ansats(15,9,0) = anf9 - plusf9 ! 15n call slug (15, 10, varmax, varupp, varned, & ansats, org, lock(15,10), dubbel, low, & - start(15,10), stopp(15,10)) + start(15,10), stopp(15,10)) do anfa = start(15,10), stopp(15,10), steg(& - 15,10) - antel(15,10) = anfa + antel(15,9) + 15,10) + antel(15,10) = anfa + antel(15,9) if (.not.(antel(15,10)==antal .and. ansats(& 15,9,1)<=2 .and. ansats(15,9,0)<=2)) & - cycle + cycle do plusfa = min(anfa,22), max(anfa - 20,0)& - , -1 - ansats(15,10,1) = plusfa - ansats(15,10,0) = anfa - plusfa + , -1 + ansats(15,10,1) = plusfa + ansats(15,10,0) = anfa - plusfa if (ansats(15,10,1)>2 .or. ansats(15,10,0)>& - 2) cycle - par = 0 - elar = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, min(j,1) - elar = elar + ansats(i,j,k) - par = mod(par + j*ansats(i,j,k),2) - end do - end do - end do - if (par /= par0) cycle - if (elar == antal) then + 2) cycle + par = 0 + elar = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, min(j,1) + elar = elar + ansats(i,j,k) + par = mod(par + j*ansats(i,j,k),2) + end do + end do + end do + if (par /= par0) cycle + if (elar == antal) then call gen (ansats, posn, posl, skal, cf, & - first, minj, maxj, par0) - else - write (*, *) 'FEL' - endif - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - if (first) then - rewind (fil_1) - else - rewind (fil_2) - endif - if (cf == 0) then - write (*, 1005) 'No configuration state has been generated.' - else if (cf == 1) then - write (*, 1005) 'One configuration state has been generated.' - else if (cf < 10) then - write (*, 1001) cf, ' configuration states have been generated.' - else if (cf < 100) then - write (*, 1002) cf, ' configuration states have been generated.' - else if (cf < 1000) then - write (*, 1003) cf, ' configuration states have been generated.' - else if (cf < 10000) then - write (*, 1004) cf, ' configuration states have been generated.' - else if (cf < 100000) then - write (*, 1006) cf, ' configuration states have been generated.' - else - write (*, *) cf, ' configuration states have been generated.' - endif + first, minj, maxj, par0) + else + write (*, *) 'FEL' + endif + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + if (first) then + rewind (fil_1) + else + rewind (fil_2) + endif + if (cf == 0) then + write (*, 1005) 'No configuration state has been generated.' + else if (cf == 1) then + write (*, 1005) 'One configuration state has been generated.' + else if (cf < 10) then + write (*, 1001) cf, ' configuration states have been generated.' + else if (cf < 100) then + write (*, 1002) cf, ' configuration states have been generated.' + else if (cf < 1000) then + write (*, 1003) cf, ' configuration states have been generated.' + else if (cf < 10000) then + write (*, 1004) cf, ' configuration states have been generated.' + else if (cf < 100000) then + write (*, 1006) cf, ' configuration states have been generated.' + else + write (*, *) cf, ' configuration states have been generated.' + endif ! 1000 format(A) - 1001 format(' ',i1,a) - 1002 format(' ',i2,a) - 1003 format(' ',i3,a) - 1004 format(' ',i4,a) - 1005 format(' ',a) - 1006 format(' ',i5,a) - 5000 format(11i2) - return - end subroutine blanda + 1001 format(' ',i1,a) + 1002 format(' ',i2,a) + 1003 format(' ',i3,a) + 1004 format(' ',i4,a) + 1005 format(' ',a) + 1006 format(' ',i5,a) + 5000 format(11i2) + return + end subroutine blanda diff --git a/src/appl/rcsfgenerate90/blanda_I.f90 b/src/appl/rcsfgenerate90/blanda_I.f90 index 973d58ef4..40e25001a 100644 --- a/src/appl/rcsfgenerate90/blanda_I.f90 +++ b/src/appl/rcsfgenerate90/blanda_I.f90 @@ -1,21 +1,21 @@ - MODULE blanda_I + MODULE blanda_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blanda (ORG, VARMAX, LOCK, MINJ, MAXJ, SKAL, NMAX, LOW, POSN& - , POSL, LIM, DUBBEL, FIRST) - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - integer :: VARMAX - logical, DIMENSION(15,0:10) :: LOCK - integer :: MINJ - integer :: MAXJ - integer :: SKAL - integer, INTENT(IN) :: NMAX - integer, DIMENSION(15,0:10) :: LOW - integer, DIMENSION(110) :: POSN - integer, DIMENSION(110) :: POSL - integer, DIMENSION(15), INTENT(IN) :: LIM - logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL - logical, INTENT(IN) :: FIRST - END SUBROUTINE - END INTERFACE - END MODULE + , POSL, LIM, DUBBEL, FIRST) + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + integer :: VARMAX + logical, DIMENSION(15,0:10) :: LOCK + integer :: MINJ + integer :: MAXJ + integer :: SKAL + integer, INTENT(IN) :: NMAX + integer, DIMENSION(15,0:10) :: LOW + integer, DIMENSION(110) :: POSN + integer, DIMENSION(110) :: POSL + integer, DIMENSION(15), INTENT(IN) :: LIM + logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL + logical, INTENT(IN) :: FIRST + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/blandb.f90 b/src/appl/rcsfgenerate90/blandb.f90 index b5d4ff70a..745cff8ea 100644 --- a/src/appl/rcsfgenerate90/blandb.f90 +++ b/src/appl/rcsfgenerate90/blandb.f90 @@ -1,43 +1,43 @@ ! last edited Januar 2, 1997 subroutine blandb(org, nmax, varmax, lock, fil, low, lim, posn, posl, & - minj, maxj) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + minj, maxj) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use sluggo_I + use sluggo_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: nmax - integer :: varmax - integer , intent(in) :: fil - integer :: minj - integer :: maxj - integer :: org(15,0:10) - integer :: low(15,0:10) - integer , intent(in) :: lim(15) - integer :: posn(110) - integer :: posl(110) - logical :: lock(15,0:10) + integer , intent(in) :: nmax + integer :: varmax + integer , intent(in) :: fil + integer :: minj + integer :: maxj + integer :: org(15,0:10) + integer :: low(15,0:10) + integer , intent(in) :: lim(15) + integer :: posn(110) + integer :: posl(110) + logical :: lock(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: antel, start - integer :: skal, cf - integer , dimension(15,0:10,0:1) :: ansats - integer , dimension(15,0:10) :: varupp, varned + integer , dimension(15,0:10) :: antel, start + integer :: skal, cf + integer , dimension(15,0:10,0:1) :: ansats + integer , dimension(15,0:10) :: varupp, varned integer :: an10, an20, an21, an30, an31, an32, an40, an41, an42, an43, k& , an50, an51, an52, an53, an54, an60, an61, an62, an63, an64, an65, & - an70, an71, an72, an73, an74, an75, an76 - integer , dimension(15,0:10) :: stopp + an70, an71, an72, an73, an74, an75, an76 + integer , dimension(15,0:10) :: stopp integer :: an80, an81, an82, an83, an84, an85, an86, an87, an90, an91, & an92, an93, an94, an95, an96, an97, an98, ana0, ana1, ana2, ana3, ana4& , ana5, ana6, ana7, ana8, ana9, plus21, plus31, plus32, plus41, plus42& @@ -56,1505 +56,1505 @@ subroutine blandb(org, nmax, varmax, lock, fil, low, lim, posn, posl, & anb6, anb7, anb8, anb9, anc0, anc1, anc2, anc3, anc4, anc5, anc6, anc7& , anc8, anc9, and0, and1, and2, and3, and4, and5, and6, and7, and8, & and9, ane0, ane1, ane2, ane3, ane4, ane5, ane6, ane7, ane8, ane9, anf0& - , anf1, anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 - real :: elar - logical :: first, finns + , anf1, anf2, anf3, anf4, anf5, anf6, anf7, anf8, anf9 + real :: elar + logical :: first, finns !----------------------------------------------- ! - cf = 0 - antal = 0 - par0 = 0 - finns = .FALSE. - do i = 1, 15 - do j = 0, min(10,i - 1) - antal = antal + org(i,j) - par0 = mod(par0 + j*org(i,j),2) - end do - end do - if (nmax < 15) then - do i = nmax + 1, 15 - org(i,:min(10,i-1)) = 0 - end do - endif + cf = 0 + antal = 0 + par0 = 0 + finns = .FALSE. + do i = 1, 15 + do j = 0, min(10,i - 1) + antal = antal + org(i,j) + par0 = mod(par0 + j*org(i,j),2) + end do + end do + if (nmax < 15) then + do i = nmax + 1, 15 + org(i,:min(10,i-1)) = 0 + end do + endif ! 1s call sluggo (1, 0, varmax, varupp, varned, ansats, org, lock(1,0), low, & - start(1,0), stopp(1,0)) - do an10 = start(1,0), stopp(1,0), -1 - antel(1,0) = an10 - if (antel(1,0)>antal .or. antel(1,0)antal .or. antel(1,0) antal) cycle - ansats(2,0,0) = an20 + , start(2,0), stopp(2,0)) + do an20 = start(2,0), stopp(2,0), -1 + antel(2,0) = an20 + antel(1,0) + if (antel(2,0) > antal) cycle + ansats(2,0,0) = an20 ! 2p call sluggo (2, 1, varmax, varupp, varned, ansats, org, lock(2,1), & - low, start(2,1), stopp(2,1)) - do an21 = start(2,1), stopp(2,1), -1 - antel(2,1) = an21 + antel(2,0) - if (antel(2,1)>antal .or. antel(2,1)antal .or. antel(2,1) antal) cycle - ansats(3,0,0) = an30 + 3,0), low, start(3,0), stopp(3,0)) + do an30 = start(3,0), stopp(3,0), -1 + antel(3,0) = an30 + antel(2,1) + if (antel(3,0) > antal) cycle + ansats(3,0,0) = an30 ! 3p call sluggo (3, 1, varmax, varupp, varned, ansats, org, & - lock(3,1), low, start(3,1), stopp(3,1)) - do an31 = start(3,1), stopp(3,1), -1 - antel(3,1) = an31 + antel(3,0) - if (antel(3,1) > antal) cycle - do plus31 = min(an31,4), max(an31 - 2,0), -1 - ansats(3,1,1) = plus31 - ansats(3,1,0) = an31 - plus31 + lock(3,1), low, start(3,1), stopp(3,1)) + do an31 = start(3,1), stopp(3,1), -1 + antel(3,1) = an31 + antel(3,0) + if (antel(3,1) > antal) cycle + do plus31 = min(an31,4), max(an31 - 2,0), -1 + ansats(3,1,1) = plus31 + ansats(3,1,0) = an31 - plus31 ! 3d call sluggo (3, 2, varmax, varupp, varned, ansats, & - org, lock(3,2), low, start(3,2), stopp(3,2)) - do an32 = start(3,2), stopp(3,2), -1 - antel(3,2) = an32 + antel(3,1) + org, lock(3,2), low, start(3,2), stopp(3,2)) + do an32 = start(3,2), stopp(3,2), -1 + antel(3,2) = an32 + antel(3,1) if (antel(3,2)>antal .or. antel(3,2) antal) cycle - ansats(4,0,0) = an40 + stopp(4,0)) + do an40 = start(4,0), stopp(4,0), -1 + antel(4,0) = an40 + antel(3,2) + if (antel(4,0) > antal) cycle + ansats(4,0,0) = an40 ! 4p call sluggo (4, 1, varmax, varupp, varned, & ansats, org, lock(4,1), low, start(4,1)& - , stopp(4,1)) - do an41 = start(4,1), stopp(4,1), -1 - antel(4,1) = an41 + antel(4,0) - if (antel(4,1) > antal) cycle + , stopp(4,1)) + do an41 = start(4,1), stopp(4,1), -1 + antel(4,1) = an41 + antel(4,0) + if (antel(4,1) > antal) cycle do plus41 = min(an41,4), max(an41 - 2,0), & - -1 - ansats(4,1,1) = plus41 - ansats(4,1,0) = an41 - plus41 + -1 + ansats(4,1,1) = plus41 + ansats(4,1,0) = an41 - plus41 ! 4d call sluggo (4, 2, varmax, varupp, varned, & ansats, org, lock(4,2), low, start(4,2)& - , stopp(4,2)) - do an42 = start(4,2), stopp(4,2), -1 - antel(4,2) = an42 + antel(4,1) - if (antel(4,2) > antal) cycle + , stopp(4,2)) + do an42 = start(4,2), stopp(4,2), -1 + antel(4,2) = an42 + antel(4,1) + if (antel(4,2) > antal) cycle do plus42 = min(an42,6), max(an42 - 4,0), & - -1 - ansats(4,2,1) = plus42 - ansats(4,2,0) = an42 - plus42 + -1 + ansats(4,2,1) = plus42 + ansats(4,2,0) = an42 - plus42 ! 4f call sluggo (4, 3, varmax, varupp, varned, & ansats, org, lock(4,3), low, start(4,3)& - , stopp(4,3)) - do an43 = start(4,3), stopp(4,3), -1 - antel(4,3) = an43 + antel(4,2) + , stopp(4,3)) + do an43 = start(4,3), stopp(4,3), -1 + antel(4,3) = an43 + antel(4,2) if (antel(4,3)>antal .or. antel(4,3) antal) cycle - ansats(5,0,0) = an50 + , stopp(5,0)) + do an50 = start(5,0), stopp(5,0), -1 + antel(5,0) = an50 + antel(4,3) + if (antel(5,0) > antal) cycle + ansats(5,0,0) = an50 ! 5p call sluggo (5, 1, varmax, varupp, varned, & ansats, org, lock(5,1), low, start(5,1)& - , stopp(5,1)) - do an51 = start(5,1), stopp(5,1), -1 - antel(5,1) = an51 + antel(5,0) - if (antel(5,1) > antal) cycle + , stopp(5,1)) + do an51 = start(5,1), stopp(5,1), -1 + antel(5,1) = an51 + antel(5,0) + if (antel(5,1) > antal) cycle do plus51 = min(an51,4), max(an51 - 2,0), & - -1 - ansats(5,1,1) = plus51 - ansats(5,1,0) = an51 - plus51 + -1 + ansats(5,1,1) = plus51 + ansats(5,1,0) = an51 - plus51 ! 5d call sluggo (5, 2, varmax, varupp, varned, & ansats, org, lock(5,2), low, start(5,2)& - , stopp(5,2)) - do an52 = start(5,2), stopp(5,2), -1 - antel(5,2) = an52 + antel(5,1) - if (antel(5,2) > antal) cycle + , stopp(5,2)) + do an52 = start(5,2), stopp(5,2), -1 + antel(5,2) = an52 + antel(5,1) + if (antel(5,2) > antal) cycle do plus52 = min(an52,6), max(an52 - 4,0), & - -1 - ansats(5,2,1) = plus52 - ansats(5,2,0) = an52 - plus52 - + -1 + ansats(5,2,1) = plus52 + ansats(5,2,0) = an52 - plus52 + ! 5f call sluggo (5, 3, varmax, varupp, varned, & ansats, org, lock(5,3), low, start(5,3)& - , stopp(5,3)) - do an53 = start(5,3), stopp(5,3), -1 - antel(5,3) = an53 + antel(5,2) - if (antel(5,3) > antal) cycle + , stopp(5,3)) + do an53 = start(5,3), stopp(5,3), -1 + antel(5,3) = an53 + antel(5,2) + if (antel(5,3) > antal) cycle do plus53 = min(an53,8), max(an53 - 6,0), & - -1 - ansats(5,3,1) = plus53 - ansats(5,3,0) = an53 - plus53 + -1 + ansats(5,3,1) = plus53 + ansats(5,3,0) = an53 - plus53 ! 5g call sluggo (5, 4, varmax, varupp, varned, & ansats, org, lock(5,4), low, start(5,4)& - , stopp(5,4)) - do an54 = start(5,4), stopp(5,4), -1 - antel(5,4) = an54 + antel(5,3) + , stopp(5,4)) + do an54 = start(5,4), stopp(5,4), -1 + antel(5,4) = an54 + antel(5,3) if (antel(5,4)>antal .or. antel(5,4)antal .or. ansats(5,4,1)>2) & - cycle - ansats(6,0,0) = an60 + cycle + ansats(6,0,0) = an60 ! 6p call sluggo (6, 1, varmax, varupp, varned, & ansats, org, lock(6,1), low, start(6,1)& - , stopp(6,1)) - do an61 = start(6,1), stopp(6,1), -1 - antel(6,1) = an61 + antel(6,0) - if (antel(6,1) > antal) cycle + , stopp(6,1)) + do an61 = start(6,1), stopp(6,1), -1 + antel(6,1) = an61 + antel(6,0) + if (antel(6,1) > antal) cycle do plus61 = min(an61,4), max(an61 - 2,0), & - -1 - ansats(6,1,1) = plus61 - ansats(6,1,0) = an61 - plus61 + -1 + ansats(6,1,1) = plus61 + ansats(6,1,0) = an61 - plus61 ! 6d call sluggo (6, 2, varmax, varupp, varned, & ansats, org, lock(6,2), low, start(6,2)& - , stopp(6,2)) - do an62 = start(6,2), stopp(6,2), -1 - antel(6,2) = an62 + antel(6,1) - if (antel(6,2) > antal) cycle + , stopp(6,2)) + do an62 = start(6,2), stopp(6,2), -1 + antel(6,2) = an62 + antel(6,1) + if (antel(6,2) > antal) cycle do plus62 = min(an62,6), max(an62 - 4,0), & - -1 - ansats(6,2,1) = plus62 - ansats(6,2,0) = an62 - plus62 + -1 + ansats(6,2,1) = plus62 + ansats(6,2,0) = an62 - plus62 ! 6f call sluggo (6, 3, varmax, varupp, varned, & ansats, org, lock(6,3), low, start(6,3)& - , stopp(6,3)) - do an63 = start(6,3), stopp(6,3), -1 - antel(6,3) = an63 + antel(6,2) - if (antel(6,3) > antal) cycle + , stopp(6,3)) + do an63 = start(6,3), stopp(6,3), -1 + antel(6,3) = an63 + antel(6,2) + if (antel(6,3) > antal) cycle do plus63 = min(an63,8), max(an63 - 6,0), & - -1 - ansats(6,3,1) = plus63 - ansats(6,3,0) = an63 - plus63 + -1 + ansats(6,3,1) = plus63 + ansats(6,3,0) = an63 - plus63 ! 6g call sluggo (6, 4, varmax, varupp, varned, & ansats, org, lock(6,4), low, start(6,4)& - , stopp(6,4)) - do an64 = start(6,4), stopp(6,4), -1 - antel(6,4) = an64 + antel(6,3) - if (antel(6,4) > antal) cycle + , stopp(6,4)) + do an64 = start(6,4), stopp(6,4), -1 + antel(6,4) = an64 + antel(6,3) + if (antel(6,4) > antal) cycle do plus64 = min(an64,10), max(an64 - 8,0), & - -1 - ansats(6,4,1) = plus64 - ansats(6,4,0) = an64 - plus64 + -1 + ansats(6,4,1) = plus64 + ansats(6,4,0) = an64 - plus64 ! 6h call sluggo (6, 5, varmax, varupp, varned, & ansats, org, lock(6,5), low, start(6,5)& - , stopp(6,5)) - do an65 = start(6,5), stopp(6,5), -1 - antel(6,5) = an65 + antel(6,4) + , stopp(6,5)) + do an65 = start(6,5), stopp(6,5), -1 + antel(6,5) = an65 + antel(6,4) if (.not.(antel(6,5)<=antal .and. ansats(6,& 4,1)<=2 .and. antel(6,5)>=lim(6))) & - cycle + cycle do plus65 = min(an65,12), max(an65 - 10,0)& - , -1 - ansats(6,5,1) = plus65 - ansats(6,5,0) = an65 - plus65 + , -1 + ansats(6,5,1) = plus65 + ansats(6,5,0) = an65 - plus65 ! 7s call sluggo (7, 0, varmax, varupp, varned, & ansats, org, lock(7,0), low, start(7,0)& - , stopp(7,0)) - do an70 = start(7,0), stopp(7,0), -1 - antel(7,0) = an70 + antel(6,5) + , stopp(7,0)) + do an70 = start(7,0), stopp(7,0), -1 + antel(7,0) = an70 + antel(6,5) if (.not.(antel(7,0)<=antal .and. ansats(6,& - 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle - ansats(7,0,0) = an70 + 5,1)<=2 .and. ansats(6,5,0)<=2)) cycle + ansats(7,0,0) = an70 ! 7p call sluggo (7, 1, varmax, varupp, varned, & ansats, org, lock(7,1), low, start(7,1)& - , stopp(7,1)) - do an71 = start(7,1), stopp(7,1), -1 - antel(7,1) = an71 + antel(7,0) - if (antel(7,1) > antal) cycle + , stopp(7,1)) + do an71 = start(7,1), stopp(7,1), -1 + antel(7,1) = an71 + antel(7,0) + if (antel(7,1) > antal) cycle do plus71 = min(an71,4), max(an71 - 2,0), & - -1 - ansats(7,1,1) = plus71 - ansats(7,1,0) = an71 - plus71 + -1 + ansats(7,1,1) = plus71 + ansats(7,1,0) = an71 - plus71 ! 7d call sluggo (7, 2, varmax, varupp, varned, & ansats, org, lock(7,2), low, start(7,2)& - , stopp(7,2)) - do an72 = start(7,2), stopp(7,2), -1 - antel(7,2) = an72 + antel(7,1) - if (antel(7,2) > antal) cycle + , stopp(7,2)) + do an72 = start(7,2), stopp(7,2), -1 + antel(7,2) = an72 + antel(7,1) + if (antel(7,2) > antal) cycle do plus72 = min(an72,6), max(an72 - 4,0), & - -1 - ansats(7,2,1) = plus72 - ansats(7,2,0) = an72 - plus72 + -1 + ansats(7,2,1) = plus72 + ansats(7,2,0) = an72 - plus72 ! 7f call sluggo (7, 3, varmax, varupp, varned, & ansats, org, lock(7,3), low, start(7,3)& - , stopp(7,3)) - do an73 = start(7,3), stopp(7,3), -1 - antel(7,3) = an73 + antel(7,2) - if (antel(7,3) > antal) cycle + , stopp(7,3)) + do an73 = start(7,3), stopp(7,3), -1 + antel(7,3) = an73 + antel(7,2) + if (antel(7,3) > antal) cycle do plus73 = min(an73,8), max(an73 - 6,0), & - -1 - ansats(7,3,1) = plus73 - ansats(7,3,0) = an73 - plus73 + -1 + ansats(7,3,1) = plus73 + ansats(7,3,0) = an73 - plus73 ! 7g call sluggo (7, 4, varmax, varupp, varned, & ansats, org, lock(7,4), low, start(7,4)& - , stopp(7,4)) - do an74 = start(7,4), stopp(7,4), -1 - antel(7,4) = an74 + antel(7,3) - if (antel(7,4) > antal) cycle + , stopp(7,4)) + do an74 = start(7,4), stopp(7,4), -1 + antel(7,4) = an74 + antel(7,3) + if (antel(7,4) > antal) cycle do plus74 = min(an74,10), max(an74 - 8,0), & - -1 - ansats(7,4,1) = plus74 - ansats(7,4,0) = an74 - plus74 + -1 + ansats(7,4,1) = plus74 + ansats(7,4,0) = an74 - plus74 ! 7h call sluggo (7, 5, varmax, varupp, varned, & ansats, org, lock(7,5), low, start(7,5)& - , stopp(7,5)) - do an75 = start(7,5), stopp(7,5), -1 - antel(7,5) = an75 + antel(7,4) + , stopp(7,5)) + do an75 = start(7,5), stopp(7,5), -1 + antel(7,5) = an75 + antel(7,4) if (antel(7,5)>antal .or. ansats(7,4,1)>2) & - cycle + cycle do plus75 = min(an75,12), max(an75 - 10,0)& - , -1 - ansats(7,5,1) = plus75 - ansats(7,5,0) = an75 - plus75 + , -1 + ansats(7,5,1) = plus75 + ansats(7,5,0) = an75 - plus75 ! 7i call sluggo (7, 6, varmax, varupp, varned, & ansats, org, lock(7,6), low, start(7,6)& - , stopp(7,6)) - do an76 = start(7,6), stopp(7,6), -1 - antel(7,6) = an76 + antel(7,5) + , stopp(7,6)) + do an76 = start(7,6), stopp(7,6), -1 + antel(7,6) = an76 + antel(7,5) if (.not.(antel(7,6)<=antal .and. ansats(7,& 5,1)<=2 .and. ansats(7,5,0)<=2 .and. & - antel(7,6)>=lim(7))) cycle + antel(7,6)>=lim(7))) cycle do plus76 = min(an76,14), max(an76 - 12,0)& - , -1 - ansats(7,6,1) = plus76 - ansats(7,6,0) = an76 - plus76 + , -1 + ansats(7,6,1) = plus76 + ansats(7,6,0) = an76 - plus76 ! 8s call sluggo (8, 0, varmax, varupp, varned, & ansats, org, lock(8,0), low, start(8,0)& - , stopp(8,0)) - do an80 = start(8,0), stopp(8,0), -1 - antel(8,0) = an80 + antel(7,6) + , stopp(8,0)) + do an80 = start(8,0), stopp(8,0), -1 + antel(8,0) = an80 + antel(7,6) if (.not.(antel(8,0)<=antal .and. ansats(7,& - 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle - ansats(8,0,0) = an80 + 6,1)<=2 .and. ansats(7,6,0)<=2)) cycle + ansats(8,0,0) = an80 ! 8p call sluggo (8, 1, varmax, varupp, varned, & ansats, org, lock(8,1), low, start(8,1)& - , stopp(8,1)) - do an81 = start(8,1), stopp(8,1), -1 - antel(8,1) = an81 + antel(8,0) - if (antel(8,1) > antal) cycle + , stopp(8,1)) + do an81 = start(8,1), stopp(8,1), -1 + antel(8,1) = an81 + antel(8,0) + if (antel(8,1) > antal) cycle do plus81 = min(an81,4), max(an81 - 2,0), & - -1 - ansats(8,1,1) = plus81 - ansats(8,1,0) = an81 - plus81 + -1 + ansats(8,1,1) = plus81 + ansats(8,1,0) = an81 - plus81 ! 8d call sluggo (8, 2, varmax, varupp, varned, & ansats, org, lock(8,2), low, start(8,2)& - , stopp(8,2)) - do an82 = start(8,2), stopp(8,2), -1 - antel(8,2) = an82 + antel(8,1) - if (antel(8,2) > antal) cycle + , stopp(8,2)) + do an82 = start(8,2), stopp(8,2), -1 + antel(8,2) = an82 + antel(8,1) + if (antel(8,2) > antal) cycle do plus82 = min(an82,6), max(an82 - 4,0), & - -1 - ansats(8,2,1) = plus82 - ansats(8,2,0) = an82 - plus82 + -1 + ansats(8,2,1) = plus82 + ansats(8,2,0) = an82 - plus82 ! 8f call sluggo (8, 3, varmax, varupp, varned, & ansats, org, lock(8,3), low, start(8,3)& - , stopp(8,3)) - do an83 = start(8,3), stopp(8,3), -1 - antel(8,3) = an83 + antel(8,2) - if (antel(8,3) > antal) cycle + , stopp(8,3)) + do an83 = start(8,3), stopp(8,3), -1 + antel(8,3) = an83 + antel(8,2) + if (antel(8,3) > antal) cycle do plus83 = min(an83,8), max(an83 - 6,0), & - -1 - ansats(8,3,1) = plus83 - ansats(8,3,0) = an83 - plus83 + -1 + ansats(8,3,1) = plus83 + ansats(8,3,0) = an83 - plus83 ! 8g call sluggo (8, 4, varmax, varupp, varned, & ansats, org, lock(8,4), low, start(8,4)& - , stopp(8,4)) - - do an84 = start(8,4), stopp(8,4), -1 - antel(8,4) = an84 + antel(8,3) - if (antel(8,4) > antal) cycle + , stopp(8,4)) + + do an84 = start(8,4), stopp(8,4), -1 + antel(8,4) = an84 + antel(8,3) + if (antel(8,4) > antal) cycle do plus84 = min(an84,10), max(an84 - 8,0), & - -1 - ansats(8,4,1) = plus84 - ansats(8,4,0) = an84 - plus84 + -1 + ansats(8,4,1) = plus84 + ansats(8,4,0) = an84 - plus84 ! 8h call sluggo (8, 5, varmax, varupp, varned, & ansats, org, lock(8,5), low, start(8,5)& - , stopp(8,5)) - do an85 = start(8,5), stopp(8,5), -1 - antel(8,5) = an85 + antel(8,4) + , stopp(8,5)) + do an85 = start(8,5), stopp(8,5), -1 + antel(8,5) = an85 + antel(8,4) if (antel(8,5)>antal .or. ansats(8,4,1)>2) & - cycle + cycle do plus85 = min(an85,12), max(an85 - 10,0)& - , -1 - ansats(8,5,1) = plus85 - ansats(8,5,0) = an85 - plus85 + , -1 + ansats(8,5,1) = plus85 + ansats(8,5,0) = an85 - plus85 ! 8i call sluggo (8, 6, varmax, varupp, varned, & ansats, org, lock(8,6), low, start(8,6)& - , stopp(8,6)) - do an86 = start(8,6), stopp(8,6), -1 - antel(8,6) = an86 + antel(8,5) + , stopp(8,6)) + do an86 = start(8,6), stopp(8,6), -1 + antel(8,6) = an86 + antel(8,5) if (.not.(antel(8,6)<=antal .and. ansats(8,& - 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(8,5,0)<=2)) cycle do plus86 = min(an86,14), max(an86 - 12,0)& - , -1 - ansats(8,6,1) = plus86 - ansats(8,6,0) = an86 - plus86 + , -1 + ansats(8,6,1) = plus86 + ansats(8,6,0) = an86 - plus86 ! 8k call sluggo (8, 7, varmax, varupp, varned, & ansats, org, lock(8,7), low, start(8,7)& - , stopp(8,7)) - do an87 = start(8,7), stopp(8,7), -1 - antel(8,7) = an87 + antel(8,6) + , stopp(8,7)) + do an87 = start(8,7), stopp(8,7), -1 + antel(8,7) = an87 + antel(8,6) if (.not.(antel(8,7)<=antal .and. ansats(8,& 6,1)<=2 .and. ansats(8,6,0)<=2 .and. & - antel(8,7)>=lim(8))) cycle + antel(8,7)>=lim(8))) cycle do plus87 = min(an87,16), max(an87 - 14,0)& - , -1 - ansats(8,7,1) = plus87 - ansats(8,7,0) = an87 - plus87 + , -1 + ansats(8,7,1) = plus87 + ansats(8,7,0) = an87 - plus87 ! 9s call sluggo (9, 0, varmax, varupp, varned, & ansats, org, lock(9,0), low, start(9,0)& - , stopp(9,0)) - do an90 = start(9,0), stopp(9,0), -1 - antel(9,0) = an90 + antel(8,7) + , stopp(9,0)) + do an90 = start(9,0), stopp(9,0), -1 + antel(9,0) = an90 + antel(8,7) if (.not.(antel(9,0)<=antal .and. ansats(8,& - 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle - ansats(9,0,0) = an90 + 7,1)<=2 .and. ansats(8,7,0)<=2)) cycle + ansats(9,0,0) = an90 ! 9p call sluggo (9, 1, varmax, varupp, varned, & ansats, org, lock(9,1), low, start(9,1)& - , stopp(9,1)) - do an91 = start(9,1), stopp(9,1), -1 - antel(9,1) = an91 + antel(9,0) - if (antel(9,1) > antal) cycle + , stopp(9,1)) + do an91 = start(9,1), stopp(9,1), -1 + antel(9,1) = an91 + antel(9,0) + if (antel(9,1) > antal) cycle do plus91 = min(an91,4), max(an91 - 2,0), & - -1 - ansats(9,1,1) = plus91 - ansats(9,1,0) = an91 - plus91 + -1 + ansats(9,1,1) = plus91 + ansats(9,1,0) = an91 - plus91 ! 9d call sluggo (9, 2, varmax, varupp, varned, & ansats, org, lock(9,2), low, start(9,2)& - , stopp(9,2)) - do an92 = start(9,2), stopp(9,2), -1 - antel(9,2) = an92 + antel(9,1) - if (antel(9,2) > antal) cycle + , stopp(9,2)) + do an92 = start(9,2), stopp(9,2), -1 + antel(9,2) = an92 + antel(9,1) + if (antel(9,2) > antal) cycle do plus92 = min(an92,6), max(an92 - 4,0), & - -1 - ansats(9,2,1) = plus92 - ansats(9,2,0) = an92 - plus92 + -1 + ansats(9,2,1) = plus92 + ansats(9,2,0) = an92 - plus92 ! 9f call sluggo (9, 3, varmax, varupp, varned, & ansats, org, lock(9,3), low, start(9,3)& - , stopp(9,3)) - do an93 = start(9,3), stopp(9,3), -1 - antel(9,3) = an93 + antel(9,2) - if (antel(9,3) > antal) cycle + , stopp(9,3)) + do an93 = start(9,3), stopp(9,3), -1 + antel(9,3) = an93 + antel(9,2) + if (antel(9,3) > antal) cycle do plus93 = min(an93,8), max(an93 - 6,0), & - -1 - ansats(9,3,1) = plus93 - ansats(9,3,0) = an93 - plus93 + -1 + ansats(9,3,1) = plus93 + ansats(9,3,0) = an93 - plus93 ! 9g call sluggo (9, 4, varmax, varupp, varned, & ansats, org, lock(9,4), low, start(9,4)& - , stopp(9,4)) - do an94 = start(9,4), stopp(9,4), -1 - antel(9,4) = an94 + antel(9,3) - if (antel(9,4) > antal) cycle + , stopp(9,4)) + do an94 = start(9,4), stopp(9,4), -1 + antel(9,4) = an94 + antel(9,3) + if (antel(9,4) > antal) cycle do plus94 = min(an94,10), max(an94 - 8,0), & - -1 - ansats(9,4,1) = plus94 - ansats(9,4,0) = an94 - plus94 + -1 + ansats(9,4,1) = plus94 + ansats(9,4,0) = an94 - plus94 ! 9h call sluggo (9, 5, varmax, varupp, varned, & ansats, org, lock(9,5), low, start(9,5)& - , stopp(9,5)) - do an95 = start(9,5), stopp(9,5), -1 - antel(9,5) = an95 + antel(9,4) + , stopp(9,5)) + do an95 = start(9,5), stopp(9,5), -1 + antel(9,5) = an95 + antel(9,4) if (antel(9,5)>antal .or. ansats(9,4,1)>2) & - cycle + cycle do plus95 = min(an95,12), max(an95 - 10,0)& - , -1 - ansats(9,5,1) = plus95 - ansats(9,5,0) = an95 - plus95 + , -1 + ansats(9,5,1) = plus95 + ansats(9,5,0) = an95 - plus95 ! 9i call sluggo (9, 6, varmax, varupp, varned, & ansats, org, lock(9,6), low, start(9,6)& - , stopp(9,6)) - do an96 = start(9,6), stopp(9,6), -1 - antel(9,6) = an96 + antel(9,5) + , stopp(9,6)) + do an96 = start(9,6), stopp(9,6), -1 + antel(9,6) = an96 + antel(9,5) if (.not.(antel(9,6)<=antal .and. ansats(9,& - 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle + 5,1)<=2 .and. ansats(9,5,0)<=2)) cycle do plus96 = min(an96,14), max(an96 - 12,0)& - , -1 - ansats(9,6,1) = plus96 - ansats(9,6,0) = an96 - plus96 + , -1 + ansats(9,6,1) = plus96 + ansats(9,6,0) = an96 - plus96 ! 9k call sluggo (9, 7, varmax, varupp, varned, & ansats, org, lock(9,7), low, start(9,7)& - , stopp(9,7)) - do an97 = start(9,7), stopp(9,7), -1 - antel(9,7) = an97 + antel(9,6) + , stopp(9,7)) + do an97 = start(9,7), stopp(9,7), -1 + antel(9,7) = an97 + antel(9,6) if (.not.(antel(9,7)<=antal .and. ansats(9,& - 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle + 6,1)<=2 .and. ansats(9,6,0)<=2)) cycle do plus97 = min(an97,16), max(an97 - 14,0)& - , -1 - ansats(9,7,1) = plus97 - ansats(9,7,0) = an97 - plus97 + , -1 + ansats(9,7,1) = plus97 + ansats(9,7,0) = an97 - plus97 ! 9l call sluggo (9, 8, varmax, varupp, varned, & ansats, org, lock(9,8), low, start(9,8)& - , stopp(9,8)) - do an98 = start(9,8), stopp(9,8), -1 - antel(9,8) = an98 + antel(9,7) + , stopp(9,8)) + do an98 = start(9,8), stopp(9,8), -1 + antel(9,8) = an98 + antel(9,7) if (.not.(antel(9,8)<=antal .and. ansats(9,& 7,1)<=2 .and. ansats(9,7,0)<=2 .and. & - antel(9,8)>=lim(9))) cycle + antel(9,8)>=lim(9))) cycle do plus98 = min(an98,18), max(an98 - 16,0)& - , -1 - ansats(9,8,1) = plus98 - ansats(9,8,0) = an98 - plus98 + , -1 + ansats(9,8,1) = plus98 + ansats(9,8,0) = an98 - plus98 ! 10s call sluggo (10, 0, varmax, varupp, varned& , ansats, org, lock(10,0), low, start(10& - ,0), stopp(10,0)) - do ana0 = start(10,0), stopp(10,0), -1 - antel(10,0) = ana0 + antel(9,8) + ,0), stopp(10,0)) + do ana0 = start(10,0), stopp(10,0), -1 + antel(10,0) = ana0 + antel(9,8) if (.not.(antel(10,0)<=antal .and. ansats(9& - ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle - ansats(10,0,0) = ana0 + ,8,1)<=2 .and. ansats(9,8,0)<=2)) cycle + ansats(10,0,0) = ana0 ! 10p call sluggo (10, 1, varmax, varupp, varned& , ansats, org, lock(10,1), low, start(10& - ,1), stopp(10,1)) - do ana1 = start(10,1), stopp(10,1), -1 - antel(10,1) = ana1 + antel(10,0) - if (antel(10,1) > antal) cycle + ,1), stopp(10,1)) + do ana1 = start(10,1), stopp(10,1), -1 + antel(10,1) = ana1 + antel(10,0) + if (antel(10,1) > antal) cycle do plusa1 = min(ana1,4), max(ana1 - 2,0), & - -1 - ansats(10,1,1) = plusa1 - ansats(10,1,0) = ana1 - plusa1 + -1 + ansats(10,1,1) = plusa1 + ansats(10,1,0) = ana1 - plusa1 ! 10d call sluggo (10, 2, varmax, varupp, varned& , ansats, org, lock(10,2), low, start(10& - ,2), stopp(10,2)) - do ana2 = start(10,2), stopp(10,2), -1 - antel(10,2) = ana2 + antel(10,1) - if (antel(10,2) > antal) cycle + ,2), stopp(10,2)) + do ana2 = start(10,2), stopp(10,2), -1 + antel(10,2) = ana2 + antel(10,1) + if (antel(10,2) > antal) cycle do plusa2 = min(ana2,6), max(ana2 - 4,0), & - -1 - ansats(10,2,1) = plusa2 - ansats(10,2,0) = ana2 - plusa2 + -1 + ansats(10,2,1) = plusa2 + ansats(10,2,0) = ana2 - plusa2 ! 10f call sluggo (10, 3, varmax, varupp, varned& , ansats, org, lock(10,3), low, start(10& - ,3), stopp(10,3)) - do ana3 = start(10,3), stopp(10,3), -1 - antel(10,3) = ana3 + antel(10,2) - if (antel(10,3) > antal) cycle + ,3), stopp(10,3)) + do ana3 = start(10,3), stopp(10,3), -1 + antel(10,3) = ana3 + antel(10,2) + if (antel(10,3) > antal) cycle do plusa3 = min(ana3,8), max(ana3 - 6,0), & - -1 - ansats(10,3,1) = plusa3 - ansats(10,3,0) = ana3 - plusa3 + -1 + ansats(10,3,1) = plusa3 + ansats(10,3,0) = ana3 - plusa3 ! 10g call sluggo (10, 4, varmax, varupp, varned& , ansats, org, lock(10,4), low, start(10& - ,4), stopp(10,4)) - do ana4 = start(10,4), stopp(10,4), -1 - antel(10,4) = ana4 + antel(10,3) - if (antel(10,4) > antal) cycle + ,4), stopp(10,4)) + do ana4 = start(10,4), stopp(10,4), -1 + antel(10,4) = ana4 + antel(10,3) + if (antel(10,4) > antal) cycle do plusa4 = min(ana4,10), max(ana4 - 8,0), & - -1 - ansats(10,4,1) = plusa4 - ansats(10,4,0) = ana4 - plusa4 + -1 + ansats(10,4,1) = plusa4 + ansats(10,4,0) = ana4 - plusa4 ! 10h call sluggo (10, 5, varmax, varupp, varned& , ansats, org, lock(10,5), low, start(10& - ,5), stopp(10,5)) - do ana5 = start(10,5), stopp(10,5), -1 - antel(10,5) = ana5 + antel(10,4) + ,5), stopp(10,5)) + do ana5 = start(10,5), stopp(10,5), -1 + antel(10,5) = ana5 + antel(10,4) if (antel(10,5)>antal .or. ansats(10,4,1)>2& - ) cycle + ) cycle do plusa5 = min(ana5,12), max(ana5 - 10,0)& - , -1 - ansats(10,5,1) = plusa5 - ansats(10,5,0) = ana5 - plusa5 + , -1 + ansats(10,5,1) = plusa5 + ansats(10,5,0) = ana5 - plusa5 ! 10i call sluggo (10, 6, varmax, varupp, varned& , ansats, org, lock(10,6), low, start(10& - ,6), stopp(10,6)) - do ana6 = start(10,6), stopp(10,6), -1 - antel(10,6) = ana6 + antel(10,5) + ,6), stopp(10,6)) + do ana6 = start(10,6), stopp(10,6), -1 + antel(10,6) = ana6 + antel(10,5) if (.not.(antel(10,6)<=antal .and. ansats(& 10,5,1)<=2 .and. ansats(10,5,0)<=2)) & - cycle + cycle do plusa6 = min(ana6,14), max(ana6 - 12,0)& - , -1 - ansats(10,6,1) = plusa6 - ansats(10,6,0) = ana6 - plusa6 + , -1 + ansats(10,6,1) = plusa6 + ansats(10,6,0) = ana6 - plusa6 ! 10k call sluggo (10, 7, varmax, varupp, varned& , ansats, org, lock(10,7), low, start(10& - ,7), stopp(10,7)) - do ana7 = start(10,7), stopp(10,7), -1 - antel(10,7) = ana7 + antel(10,6) + ,7), stopp(10,7)) + do ana7 = start(10,7), stopp(10,7), -1 + antel(10,7) = ana7 + antel(10,6) if (.not.(antel(10,7)<=antal .and. ansats(& 10,6,1)<=2 .and. ansats(10,6,0)<=2)) & - cycle + cycle do plusa7 = min(ana7,16), max(ana7 - 14,0)& - , -1 - ansats(10,7,1) = plusa7 - ansats(10,7,0) = ana7 - plusa7 + , -1 + ansats(10,7,1) = plusa7 + ansats(10,7,0) = ana7 - plusa7 ! 10l call sluggo (10, 8, varmax, varupp, varned& , ansats, org, lock(10,8), low, start(10& - ,8), stopp(10,8)) - do ana8 = start(10,8), stopp(10,8), -1 - antel(10,8) = ana8 + antel(10,7) + ,8), stopp(10,8)) + do ana8 = start(10,8), stopp(10,8), -1 + antel(10,8) = ana8 + antel(10,7) if (.not.(antel(10,8)<=antal .and. ansats(& 10,7,1)<=2 .and. ansats(10,7,0)<=2)) & - cycle + cycle do plusa8 = min(ana8,18), max(ana8 - 16,0)& - , -1 - ansats(10,8,1) = plusa8 - ansats(10,8,0) = ana8 - plusa8 + , -1 + ansats(10,8,1) = plusa8 + ansats(10,8,0) = ana8 - plusa8 ! 10m call sluggo (10, 9, varmax, varupp, varned& , ansats, org, lock(10,9), low, start(10& - ,9), stopp(10,9)) - do ana9 = start(10,9), stopp(10,9), -1 - antel(10,9) = ana9 + antel(10,8) + ,9), stopp(10,9)) + do ana9 = start(10,9), stopp(10,9), -1 + antel(10,9) = ana9 + antel(10,8) if (.not.(antel(10,9)<=antal .and. ansats(& 10,8,1)<=2 .and. ansats(10,8,0)<=2& - .and. antel(10,9)>=lim(10))) cycle + .and. antel(10,9)>=lim(10))) cycle do plusa9 = min(ana9,20), max(ana9 - 18,0)& - , -1 - ansats(10,9,1) = plusa9 - ansats(10,9,0) = ana9 - plusa9 + , -1 + ansats(10,9,1) = plusa9 + ansats(10,9,0) = ana9 - plusa9 ! 11s call sluggo (11, 0, varmax, varupp, varned& , ansats, org, lock(11,0), low, start(11& - ,0), stopp(11,0)) - do anb0 = start(11,0), stopp(11,0), -1 - antel(11,0) = anb0 + antel(10,9) + ,0), stopp(11,0)) + do anb0 = start(11,0), stopp(11,0), -1 + antel(11,0) = anb0 + antel(10,9) if (.not.(antel(11,0)<=antal .and. ansats(& 10,9,1)<=2 .and. ansats(10,9,0)<=2)) & - cycle - ansats(11,0,0) = anb0 + cycle + ansats(11,0,0) = anb0 ! 11p call sluggo (11, 1, varmax, varupp, varned& , ansats, org, lock(11,1), low, start(11& - ,1), stopp(11,1)) - do anb1 = start(11,1), stopp(11,1), -1 - antel(11,1) = anb1 + antel(11,0) - if (antel(11,1) > antal) cycle + ,1), stopp(11,1)) + do anb1 = start(11,1), stopp(11,1), -1 + antel(11,1) = anb1 + antel(11,0) + if (antel(11,1) > antal) cycle do plusb1 = min(anb1,4), max(anb1 - 2,0), & - -1 - ansats(11,1,1) = plusb1 - ansats(11,1,0) = anb1 - plusb1 + -1 + ansats(11,1,1) = plusb1 + ansats(11,1,0) = anb1 - plusb1 ! 11d call sluggo (11, 2, varmax, varupp, varned& , ansats, org, lock(11,2), low, start(11& - ,2), stopp(11,2)) - do anb2 = start(11,2), stopp(11,2), -1 - antel(11,2) = anb2 + antel(11,1) - if (antel(11,2) > antal) cycle + ,2), stopp(11,2)) + do anb2 = start(11,2), stopp(11,2), -1 + antel(11,2) = anb2 + antel(11,1) + if (antel(11,2) > antal) cycle do plusb2 = min(anb2,6), max(anb2 - 4,0), & - -1 - ansats(11,2,1) = plusb2 - ansats(11,2,0) = anb2 - plusb2 + -1 + ansats(11,2,1) = plusb2 + ansats(11,2,0) = anb2 - plusb2 ! 11f call sluggo (11, 3, varmax, varupp, varned& , ansats, org, lock(11,3), low, start(11& - ,3), stopp(11,3)) - do anb3 = start(11,3), stopp(11,3), -1 - antel(11,3) = anb3 + antel(11,2) - if (antel(11,3) > antal) cycle + ,3), stopp(11,3)) + do anb3 = start(11,3), stopp(11,3), -1 + antel(11,3) = anb3 + antel(11,2) + if (antel(11,3) > antal) cycle do plusb3 = min(anb3,8), max(anb3 - 6,0), & - -1 - ansats(11,3,1) = plusb3 - ansats(11,3,0) = anb3 - plusb3 + -1 + ansats(11,3,1) = plusb3 + ansats(11,3,0) = anb3 - plusb3 ! 11g call sluggo (11, 4, varmax, varupp, varned& , ansats, org, lock(11,4), low, start(11& - ,4), stopp(11,4)) - do anb4 = start(11,4), stopp(11,4), -1 - antel(11,4) = anb4 + antel(11,3) - if (antel(11,4) > antal) cycle + ,4), stopp(11,4)) + do anb4 = start(11,4), stopp(11,4), -1 + antel(11,4) = anb4 + antel(11,3) + if (antel(11,4) > antal) cycle do plusb4 = min(anb4,10), max(anb4 - 8,0), & - -1 - ansats(11,4,1) = plusb4 - ansats(11,4,0) = anb4 - plusb4 + -1 + ansats(11,4,1) = plusb4 + ansats(11,4,0) = anb4 - plusb4 ! 11h call sluggo (11, 5, varmax, varupp, varned& , ansats, org, lock(11,5), low, start(11& - ,5), stopp(11,5)) - do anb5 = start(11,5), stopp(11,5), -1 - antel(11,5) = anb5 + antel(11,4) + ,5), stopp(11,5)) + do anb5 = start(11,5), stopp(11,5), -1 + antel(11,5) = anb5 + antel(11,4) if (antel(11,5)>antal .or. ansats(11,4,1)>2& - ) cycle + ) cycle do plusb5 = min(anb5,12), max(anb5 - 10,0)& - , -1 - ansats(11,5,1) = plusb5 - ansats(11,5,0) = anb5 - plusb5 + , -1 + ansats(11,5,1) = plusb5 + ansats(11,5,0) = anb5 - plusb5 ! 11i call sluggo (11, 6, varmax, varupp, varned& , ansats, org, lock(11,6), low, start(11& - ,6), stopp(11,6)) - do anb6 = start(11,6), stopp(11,6), -1 - antel(11,6) = anb6 + antel(11,5) + ,6), stopp(11,6)) + do anb6 = start(11,6), stopp(11,6), -1 + antel(11,6) = anb6 + antel(11,5) if (.not.(antel(11,6)<=antal .and. ansats(& 11,5,1)<=2 .and. ansats(11,5,0)<=2)) & - cycle + cycle do plusb6 = min(anb6,14), max(anb6 - 12,0)& - , -1 - ansats(11,6,1) = plusb6 - ansats(11,6,0) = anb6 - plusb6 + , -1 + ansats(11,6,1) = plusb6 + ansats(11,6,0) = anb6 - plusb6 ! 11k call sluggo (11, 7, varmax, varupp, varned& , ansats, org, lock(11,7), low, start(11& - ,7), stopp(11,7)) - do anb7 = start(11,7), stopp(11,7), -1 - antel(11,7) = anb7 + antel(11,6) + ,7), stopp(11,7)) + do anb7 = start(11,7), stopp(11,7), -1 + antel(11,7) = anb7 + antel(11,6) if (.not.(antel(11,7)<=antal .and. ansats(& 11,6,1)<=2 .and. ansats(11,6,0)<=2)) & - cycle + cycle do plusb7 = min(anb7,16), max(anb7 - 14,0)& - , -1 - ansats(11,7,1) = plusb7 - ansats(11,7,0) = anb7 - plusb7 + , -1 + ansats(11,7,1) = plusb7 + ansats(11,7,0) = anb7 - plusb7 ! 11l call sluggo (11, 8, varmax, varupp, varned& , ansats, org, lock(11,8), low, start(11& - ,8), stopp(11,8)) - do anb8 = start(11,8), stopp(11,8), -1 - antel(11,8) = anb8 + antel(11,7) + ,8), stopp(11,8)) + do anb8 = start(11,8), stopp(11,8), -1 + antel(11,8) = anb8 + antel(11,7) if (.not.(antel(11,8)<=antal .and. ansats(& 11,7,1)<=2 .and. ansats(11,7,0)<=2)) & - cycle + cycle do plusb8 = min(anb8,18), max(anb8 - 16,0)& - , -1 - ansats(11,8,1) = plusb8 - ansats(11,8,0) = anb8 - plusb8 + , -1 + ansats(11,8,1) = plusb8 + ansats(11,8,0) = anb8 - plusb8 ! 11m call sluggo (11, 9, varmax, varupp, varned& , ansats, org, lock(11,9), low, start(11& - ,9), stopp(11,9)) - do anb9 = start(11,9), stopp(11,9), -1 - antel(11,9) = anb9 + antel(11,8) + ,9), stopp(11,9)) + do anb9 = start(11,9), stopp(11,9), -1 + antel(11,9) = anb9 + antel(11,8) if (.not.(antel(11,9)<=antal .and. ansats(& 11,8,1)<=2 .and. ansats(11,8,0)<=2)) & - cycle + cycle do plusb9 = min(anb9,20), max(anb9 - 18,0)& - , -1 - ansats(11,9,1) = plusb9 - ansats(11,9,0) = anb9 - plusb9 + , -1 + ansats(11,9,1) = plusb9 + ansats(11,9,0) = anb9 - plusb9 ! 11n call sluggo (11, 10, varmax, varupp, varned& , ansats, org, lock(11,10), low, start(& - 11,10), stopp(11,10)) - do anba = start(11,10), stopp(11,10), -1 - antel(11,10) = anba + antel(11,9) + 11,10), stopp(11,10)) + do anba = start(11,10), stopp(11,10), -1 + antel(11,10) = anba + antel(11,9) if (.not.(antel(11,10)<=antal .and. ansats(& 11,9,1)<=2 .and. ansats(11,9,0)<=2& - .and. antel(11,10)>=lim(11))) cycle + .and. antel(11,10)>=lim(11))) cycle do plusba = min(anba,22), max(anba - 20,0)& - , -1 - ansats(11,10,1) = plusba - ansats(11,10,0) = anba - plusba + , -1 + ansats(11,10,1) = plusba + ansats(11,10,0) = anba - plusba ! 12s call sluggo (12, 0, varmax, varupp, varned& , ansats, org, lock(12,0), low, start(12& - ,0), stopp(12,0)) - do anc0 = start(12,0), stopp(12,0), -1 - antel(12,0) = anc0 + antel(11,10) + ,0), stopp(12,0)) + do anc0 = start(12,0), stopp(12,0), -1 + antel(12,0) = anc0 + antel(11,10) if (.not.(antel(12,0)<=antal .and. ansats(& 11,10,1)<=2 .and. ansats(11,10,0)<=2)) & - cycle - ansats(12,0,0) = anc0 + cycle + ansats(12,0,0) = anc0 ! 12p call sluggo (12, 1, varmax, varupp, varned& , ansats, org, lock(12,1), low, start(12& - ,1), stopp(12,1)) - do anc1 = start(12,1), stopp(12,1), -1 - antel(12,1) = anc1 + antel(12,0) - if (antel(12,1) > antal) cycle + ,1), stopp(12,1)) + do anc1 = start(12,1), stopp(12,1), -1 + antel(12,1) = anc1 + antel(12,0) + if (antel(12,1) > antal) cycle do plusc1 = min(anc1,4), max(anc1 - 2,0), & - -1 - ansats(12,1,1) = plusc1 - ansats(12,1,0) = anc1 - plusc1 + -1 + ansats(12,1,1) = plusc1 + ansats(12,1,0) = anc1 - plusc1 ! 12d call sluggo (12, 2, varmax, varupp, varned& , ansats, org, lock(12,2), low, start(12& - ,2), stopp(12,2)) - do anc2 = start(12,2), stopp(12,2), -1 - antel(12,2) = anc2 + antel(12,1) - if (antel(12,2) > antal) cycle + ,2), stopp(12,2)) + do anc2 = start(12,2), stopp(12,2), -1 + antel(12,2) = anc2 + antel(12,1) + if (antel(12,2) > antal) cycle do plusc2 = min(anc2,6), max(anc2 - 4,0), & - -1 - ansats(12,2,1) = plusc2 - ansats(12,2,0) = anc2 - plusc2 + -1 + ansats(12,2,1) = plusc2 + ansats(12,2,0) = anc2 - plusc2 ! 12f call sluggo (12, 3, varmax, varupp, varned& , ansats, org, lock(12,3), low, start(12& - ,3), stopp(12,3)) - do anc3 = start(12,3), stopp(12,3), -1 - antel(12,3) = anc3 + antel(12,2) - if (antel(12,3) > antal) cycle + ,3), stopp(12,3)) + do anc3 = start(12,3), stopp(12,3), -1 + antel(12,3) = anc3 + antel(12,2) + if (antel(12,3) > antal) cycle do plusc3 = min(anc3,8), max(anc3 - 6,0), & - -1 - ansats(12,3,1) = plusc3 - ansats(12,3,0) = anc3 - plusc3 + -1 + ansats(12,3,1) = plusc3 + ansats(12,3,0) = anc3 - plusc3 ! 12g call sluggo (12, 4, varmax, varupp, varned& , ansats, org, lock(12,4), low, start(12& - ,4), stopp(12,4)) - do anc4 = start(12,4), stopp(12,4), -1 - antel(12,4) = anc4 + antel(12,3) - if (antel(12,4) > antal) cycle + ,4), stopp(12,4)) + do anc4 = start(12,4), stopp(12,4), -1 + antel(12,4) = anc4 + antel(12,3) + if (antel(12,4) > antal) cycle do plusc4 = min(anc4,10), max(anc4 - 8,0), & - -1 - ansats(12,4,1) = plusc4 - ansats(12,4,0) = anc4 - plusc4 + -1 + ansats(12,4,1) = plusc4 + ansats(12,4,0) = anc4 - plusc4 ! 12h call sluggo (12, 5, varmax, varupp, varned& , ansats, org, lock(12,5), low, start(12& - ,5), stopp(12,5)) - do anc5 = start(12,5), stopp(12,5), -1 - antel(12,5) = anc5 + antel(12,4) + ,5), stopp(12,5)) + do anc5 = start(12,5), stopp(12,5), -1 + antel(12,5) = anc5 + antel(12,4) if (antel(12,5)>antal .or. ansats(12,4,1)>2& - ) cycle + ) cycle do plusc5 = min(anc5,12), max(anc5 - 10,0)& - , -1 - ansats(12,5,1) = plusc5 - ansats(12,5,0) = anc5 - plusc5 + , -1 + ansats(12,5,1) = plusc5 + ansats(12,5,0) = anc5 - plusc5 ! 12i call sluggo (12, 6, varmax, varupp, varned& , ansats, org, lock(12,6), low, start(12& - ,6), stopp(12,6)) - do anc6 = start(12,6), stopp(12,6), -1 - antel(12,6) = anc6 + antel(12,5) + ,6), stopp(12,6)) + do anc6 = start(12,6), stopp(12,6), -1 + antel(12,6) = anc6 + antel(12,5) if (.not.(antel(12,6)<=antal .and. ansats(& 12,5,1)<=2 .and. ansats(12,5,0)<=2)) & - cycle + cycle do plusc6 = min(anc6,14), max(anc6 - 12,0)& - , -1 - ansats(12,6,1) = plusc6 - ansats(12,6,0) = anc6 - plusc6 + , -1 + ansats(12,6,1) = plusc6 + ansats(12,6,0) = anc6 - plusc6 ! 12k call sluggo (12, 7, varmax, varupp, varned& , ansats, org, lock(12,7), low, start(12& - ,7), stopp(12,7)) - do anc7 = start(12,7), stopp(12,7), -1 - antel(12,7) = anc7 + antel(12,6) + ,7), stopp(12,7)) + do anc7 = start(12,7), stopp(12,7), -1 + antel(12,7) = anc7 + antel(12,6) if (.not.(antel(12,7)<=antal .and. ansats(& 12,6,1)<=2 .and. ansats(12,6,0)<=2)) & - cycle + cycle do plusc7 = min(anc7,16), max(anc7 - 14,0)& - , -1 - ansats(12,7,1) = plusc7 - ansats(12,7,0) = anc7 - plusc7 + , -1 + ansats(12,7,1) = plusc7 + ansats(12,7,0) = anc7 - plusc7 ! 12l call sluggo (12, 8, varmax, varupp, varned& , ansats, org, lock(12,8), low, start(12& - ,8), stopp(12,8)) - do anc8 = start(12,8), stopp(12,8), -1 - antel(12,8) = anc8 + antel(12,7) + ,8), stopp(12,8)) + do anc8 = start(12,8), stopp(12,8), -1 + antel(12,8) = anc8 + antel(12,7) if (.not.(antel(12,8)<=antal .and. ansats(& 12,7,1)<=2 .and. ansats(12,7,0)<=2)) & - cycle + cycle do plusc8 = min(anc8,18), max(anc8 - 16,0)& - , -1 - ansats(12,8,1) = plusc8 - ansats(12,8,0) = anc8 - plusc8 + , -1 + ansats(12,8,1) = plusc8 + ansats(12,8,0) = anc8 - plusc8 ! 12m call sluggo (12, 9, varmax, varupp, varned& , ansats, org, lock(12,9), low, start(12& - ,9), stopp(12,9)) - do anc9 = start(12,9), stopp(12,9), -1 - antel(12,9) = anc9 + antel(12,8) + ,9), stopp(12,9)) + do anc9 = start(12,9), stopp(12,9), -1 + antel(12,9) = anc9 + antel(12,8) if (.not.(antel(12,9)<=antal .and. ansats(& 12,8,1)<=2 .and. ansats(12,8,0)<=2)) & - cycle + cycle do plusc9 = min(anc9,20), max(anc9 - 18,0)& - , -1 - ansats(12,9,1) = plusc9 - ansats(12,9,0) = anc9 - plusc9 + , -1 + ansats(12,9,1) = plusc9 + ansats(12,9,0) = anc9 - plusc9 ! 12n call sluggo (12, 10, varmax, varupp, varned& , ansats, org, lock(12,10), low, start(& - 12,10), stopp(12,10)) - do anca = start(12,10), stopp(12,10), -1 - antel(12,10) = anca + antel(12,9) + 12,10), stopp(12,10)) + do anca = start(12,10), stopp(12,10), -1 + antel(12,10) = anca + antel(12,9) if (.not.(antel(12,10)<=antal .and. ansats(& 12,9,1)<=2 .and. ansats(12,9,0)<=2& - .and. antel(12,10)>=lim(12))) cycle + .and. antel(12,10)>=lim(12))) cycle do plusca = min(anca,22), max(anca - 20,0)& - , -1 - ansats(12,10,1) = plusca - ansats(12,10,0) = anca - plusca + , -1 + ansats(12,10,1) = plusca + ansats(12,10,0) = anca - plusca ! 13s call sluggo (13, 0, varmax, varupp, varned& , ansats, org, lock(13,0), low, start(13& - ,0), stopp(13,0)) - do and0 = start(13,0), stopp(13,0), -1 - antel(13,0) = and0 + antel(12,10) + ,0), stopp(13,0)) + do and0 = start(13,0), stopp(13,0), -1 + antel(13,0) = and0 + antel(12,10) if (.not.(antel(13,0)<=antal .and. ansats(& 12,10,1)<=2 .and. ansats(12,10,0)<=2)) & - cycle - ansats(13,0,0) = and0 + cycle + ansats(13,0,0) = and0 ! 13p call sluggo (13, 1, varmax, varupp, varned& , ansats, org, lock(13,1), low, start(13& - ,1), stopp(13,1)) - do and1 = start(13,1), stopp(13,1), -1 - antel(13,1) = and1 + antel(13,0) - if (antel(13,1) > antal) cycle + ,1), stopp(13,1)) + do and1 = start(13,1), stopp(13,1), -1 + antel(13,1) = and1 + antel(13,0) + if (antel(13,1) > antal) cycle do plusd1 = min(and1,4), max(and1 - 2,0), & - -1 - ansats(13,1,1) = plusd1 - ansats(13,1,0) = and1 - plusd1 + -1 + ansats(13,1,1) = plusd1 + ansats(13,1,0) = and1 - plusd1 ! 13d call sluggo (13, 2, varmax, varupp, varned& , ansats, org, lock(13,2), low, start(13& - ,2), stopp(13,2)) - do and2 = start(13,2), stopp(13,2), -1 - antel(13,2) = and2 + antel(13,1) - if (antel(13,2) > antal) cycle + ,2), stopp(13,2)) + do and2 = start(13,2), stopp(13,2), -1 + antel(13,2) = and2 + antel(13,1) + if (antel(13,2) > antal) cycle do plusd2 = min(and2,6), max(and2 - 4,0), & - -1 - ansats(13,2,1) = plusd2 - ansats(13,2,0) = and2 - plusd2 + -1 + ansats(13,2,1) = plusd2 + ansats(13,2,0) = and2 - plusd2 ! 13f call sluggo (13, 3, varmax, varupp, varned& , ansats, org, lock(13,3), low, start(13& - ,3), stopp(13,3)) - do and3 = start(13,3), stopp(13,3), -1 - antel(13,3) = and3 + antel(13,2) - if (antel(13,3) > antal) cycle + ,3), stopp(13,3)) + do and3 = start(13,3), stopp(13,3), -1 + antel(13,3) = and3 + antel(13,2) + if (antel(13,3) > antal) cycle do plusd3 = min(and3,8), max(and3 - 6,0), & - -1 - ansats(13,3,1) = plusd3 - ansats(13,3,0) = and3 - plusd3 + -1 + ansats(13,3,1) = plusd3 + ansats(13,3,0) = and3 - plusd3 ! 13g call sluggo (13, 4, varmax, varupp, varned& , ansats, org, lock(13,4), low, start(13& - ,4), stopp(13,4)) - do and4 = start(13,4), stopp(13,4), -1 - antel(13,4) = and4 + antel(13,3) - if (antel(13,4) > antal) cycle + ,4), stopp(13,4)) + do and4 = start(13,4), stopp(13,4), -1 + antel(13,4) = and4 + antel(13,3) + if (antel(13,4) > antal) cycle do plusd4 = min(and4,10), max(and4 - 8,0), & - -1 - ansats(13,4,1) = plusd4 - ansats(13,4,0) = and4 - plusd4 + -1 + ansats(13,4,1) = plusd4 + ansats(13,4,0) = and4 - plusd4 ! 13h call sluggo (13, 5, varmax, varupp, varned& , ansats, org, lock(13,5), low, start(13& - ,5), stopp(13,5)) - do and5 = start(13,5), stopp(13,5), -1 - antel(13,5) = and5 + antel(13,4) + ,5), stopp(13,5)) + do and5 = start(13,5), stopp(13,5), -1 + antel(13,5) = and5 + antel(13,4) if (antel(13,5)>antal .or. ansats(13,4,1)>2& - ) cycle + ) cycle do plusd5 = min(and5,12), max(and5 - 10,0)& - , -1 - ansats(13,5,1) = plusd5 - ansats(13,5,0) = and5 - plusd5 + , -1 + ansats(13,5,1) = plusd5 + ansats(13,5,0) = and5 - plusd5 ! 13i call sluggo (13, 6, varmax, varupp, varned& , ansats, org, lock(13,6), low, start(13& - ,6), stopp(13,6)) - do and6 = start(13,6), stopp(13,6), -1 - antel(13,6) = and6 + antel(13,5) + ,6), stopp(13,6)) + do and6 = start(13,6), stopp(13,6), -1 + antel(13,6) = and6 + antel(13,5) if (.not.(antel(13,6)<=antal .and. ansats(& 13,5,1)<=2 .and. ansats(13,5,0)<=2)) & - cycle + cycle do plusd6 = min(and6,14), max(and6 - 12,0)& - , -1 - ansats(13,6,1) = plusd6 - ansats(13,6,0) = and6 - plusd6 + , -1 + ansats(13,6,1) = plusd6 + ansats(13,6,0) = and6 - plusd6 ! 13k call sluggo (13, 7, varmax, varupp, varned& , ansats, org, lock(13,7), low, start(13& - ,7), stopp(13,7)) - do and7 = start(13,7), stopp(13,7), -1 - antel(13,7) = and7 + antel(13,6) + ,7), stopp(13,7)) + do and7 = start(13,7), stopp(13,7), -1 + antel(13,7) = and7 + antel(13,6) if (.not.(antel(13,7)<=antal .and. ansats(& 13,6,1)<=2 .and. ansats(13,6,0)<=2)) & - cycle + cycle do plusd7 = min(and7,16), max(and7 - 14,0)& - , -1 - ansats(13,7,1) = plusd7 - ansats(13,7,0) = and7 - plusd7 + , -1 + ansats(13,7,1) = plusd7 + ansats(13,7,0) = and7 - plusd7 ! 13l call sluggo (13, 8, varmax, varupp, varned& , ansats, org, lock(13,8), low, start(13& - ,8), stopp(13,8)) - do and8 = start(13,8), stopp(13,8), -1 - antel(13,8) = and8 + antel(13,7) + ,8), stopp(13,8)) + do and8 = start(13,8), stopp(13,8), -1 + antel(13,8) = and8 + antel(13,7) if (.not.(antel(13,8)<=antal .and. ansats(& 13,7,1)<=2 .and. ansats(13,7,0)<=2)) & - cycle + cycle do plusd8 = min(and8,18), max(and8 - 16,0)& - , -1 - ansats(13,8,1) = plusd8 - ansats(13,8,0) = and8 - plusd8 + , -1 + ansats(13,8,1) = plusd8 + ansats(13,8,0) = and8 - plusd8 ! 13m call sluggo (13, 9, varmax, varupp, varned& , ansats, org, lock(13,9), low, start(13& - ,9), stopp(13,9)) - do and9 = start(13,9), stopp(13,9), -1 - antel(13,9) = and9 + antel(13,8) + ,9), stopp(13,9)) + do and9 = start(13,9), stopp(13,9), -1 + antel(13,9) = and9 + antel(13,8) if (.not.(antel(13,9)<=antal .and. ansats(& 13,8,1)<=2 .and. ansats(13,8,0)<=2)) & - cycle + cycle do plusd9 = min(and9,20), max(and9 - 18,0)& - , -1 - ansats(13,9,1) = plusd9 - ansats(13,9,0) = and9 - plusd9 + , -1 + ansats(13,9,1) = plusd9 + ansats(13,9,0) = and9 - plusd9 ! 13n call sluggo (13, 10, varmax, varupp, varned& , ansats, org, lock(13,10), low, start(& - 13,10), stopp(13,10)) - do anda = start(13,10), stopp(13,10), -1 - antel(13,10) = anda + antel(13,9) + 13,10), stopp(13,10)) + do anda = start(13,10), stopp(13,10), -1 + antel(13,10) = anda + antel(13,9) if (.not.(antel(13,10)<=antal .and. ansats(& 13,9,1)<=2 .and. ansats(13,9,0)<=2& - .and. antel(13,10)>=lim(13))) cycle + .and. antel(13,10)>=lim(13))) cycle do plusda = min(anda,22), max(anda - 20,0)& - , -1 - ansats(13,10,1) = plusda - ansats(13,10,0) = anda - plusda + , -1 + ansats(13,10,1) = plusda + ansats(13,10,0) = anda - plusda ! 14s call sluggo (14, 0, varmax, varupp, varned& , ansats, org, lock(14,0), low, start(14& - ,0), stopp(14,0)) - do ane0 = start(14,0), stopp(14,0), -1 - antel(14,0) = ane0 + antel(13,10) + ,0), stopp(14,0)) + do ane0 = start(14,0), stopp(14,0), -1 + antel(14,0) = ane0 + antel(13,10) if (.not.(antel(14,0)<=antal .and. ansats(& 13,10,1)<=2 .and. ansats(13,10,0)<=2)) & - cycle - ansats(14,0,0) = ane0 + cycle + ansats(14,0,0) = ane0 ! 14p call sluggo (14, 1, varmax, varupp, varned& , ansats, org, lock(14,1), low, start(14& - ,1), stopp(14,1)) - do ane1 = start(14,1), stopp(14,1), -1 - antel(14,1) = ane1 + antel(14,0) - if (antel(14,1) > antal) cycle + ,1), stopp(14,1)) + do ane1 = start(14,1), stopp(14,1), -1 + antel(14,1) = ane1 + antel(14,0) + if (antel(14,1) > antal) cycle do pluse1 = min(ane1,4), max(ane1 - 2,0), & - -1 - ansats(14,1,1) = pluse1 - ansats(14,1,0) = ane1 - pluse1 + -1 + ansats(14,1,1) = pluse1 + ansats(14,1,0) = ane1 - pluse1 ! 14d call sluggo (14, 2, varmax, varupp, varned& , ansats, org, lock(14,2), low, start(14& - ,2), stopp(14,2)) - do ane2 = start(14,2), stopp(14,2), -1 - antel(14,2) = ane2 + antel(14,1) - if (antel(14,2) > antal) cycle + ,2), stopp(14,2)) + do ane2 = start(14,2), stopp(14,2), -1 + antel(14,2) = ane2 + antel(14,1) + if (antel(14,2) > antal) cycle do pluse2 = min(ane2,6), max(ane2 - 4,0), & - -1 - ansats(14,2,1) = pluse2 - ansats(14,2,0) = ane2 - pluse2 + -1 + ansats(14,2,1) = pluse2 + ansats(14,2,0) = ane2 - pluse2 ! 14f call sluggo (14, 3, varmax, varupp, varned& , ansats, org, lock(14,3), low, start(14& - ,3), stopp(14,3)) - do ane3 = start(14,3), stopp(14,3), -1 - antel(14,3) = ane3 + antel(14,2) - if (antel(14,3) > antal) cycle + ,3), stopp(14,3)) + do ane3 = start(14,3), stopp(14,3), -1 + antel(14,3) = ane3 + antel(14,2) + if (antel(14,3) > antal) cycle do pluse3 = min(ane3,8), max(ane3 - 6,0), & - -1 - ansats(14,3,1) = pluse3 - ansats(14,3,0) = ane3 - pluse3 + -1 + ansats(14,3,1) = pluse3 + ansats(14,3,0) = ane3 - pluse3 ! 14g call sluggo (14, 4, varmax, varupp, varned& , ansats, org, lock(14,4), low, start(14& - ,4), stopp(14,4)) - do ane4 = start(14,4), stopp(14,4), -1 - antel(14,4) = ane4 + antel(14,3) - if (antel(14,4) > antal) cycle + ,4), stopp(14,4)) + do ane4 = start(14,4), stopp(14,4), -1 + antel(14,4) = ane4 + antel(14,3) + if (antel(14,4) > antal) cycle do pluse4 = min(ane4,10), max(ane4 - 8,0), & - -1 - ansats(14,4,1) = pluse4 - ansats(14,4,0) = ane4 - pluse4 + -1 + ansats(14,4,1) = pluse4 + ansats(14,4,0) = ane4 - pluse4 ! 14h call sluggo (14, 5, varmax, varupp, varned& , ansats, org, lock(14,5), low, start(14& - ,5), stopp(14,5)) - do ane5 = start(14,5), stopp(14,5), -1 - antel(14,5) = ane5 + antel(14,4) + ,5), stopp(14,5)) + do ane5 = start(14,5), stopp(14,5), -1 + antel(14,5) = ane5 + antel(14,4) if (antel(14,5)>antal .or. ansats(14,4,1)>2& - ) cycle + ) cycle do pluse5 = min(ane5,12), max(ane5 - 10,0)& - , -1 - ansats(14,5,1) = pluse5 - ansats(14,5,0) = ane5 - pluse5 + , -1 + ansats(14,5,1) = pluse5 + ansats(14,5,0) = ane5 - pluse5 ! 14i call sluggo (14, 6, varmax, varupp, varned& , ansats, org, lock(14,6), low, start(14& - ,6), stopp(14,6)) - do ane6 = start(14,6), stopp(14,6), -1 - antel(14,6) = ane6 + antel(14,5) + ,6), stopp(14,6)) + do ane6 = start(14,6), stopp(14,6), -1 + antel(14,6) = ane6 + antel(14,5) if (.not.(antel(14,6)<=antal .and. ansats(& 14,5,1)<=2 .and. ansats(14,5,0)<=2)) & - cycle + cycle do pluse6 = min(ane6,14), max(ane6 - 12,0)& - , -1 - ansats(14,6,1) = pluse6 - ansats(14,6,0) = ane6 - pluse6 + , -1 + ansats(14,6,1) = pluse6 + ansats(14,6,0) = ane6 - pluse6 ! 14k call sluggo (14, 7, varmax, varupp, varned& , ansats, org, lock(14,7), low, start(14& - ,7), stopp(14,7)) - do ane7 = start(14,7), stopp(14,7), -1 - antel(14,7) = ane7 + antel(14,6) + ,7), stopp(14,7)) + do ane7 = start(14,7), stopp(14,7), -1 + antel(14,7) = ane7 + antel(14,6) if (.not.(antel(14,7)<=antal .and. ansats(& 14,6,1)<=2 .and. ansats(14,6,0)<=2)) & - cycle + cycle do pluse7 = min(ane7,16), max(ane7 - 14,0)& - , -1 - ansats(14,7,1) = pluse7 - ansats(14,7,0) = ane7 - pluse7 + , -1 + ansats(14,7,1) = pluse7 + ansats(14,7,0) = ane7 - pluse7 ! 14l call sluggo (14, 8, varmax, varupp, varned& , ansats, org, lock(14,8), low, start(14& - ,8), stopp(14,8)) - do ane8 = start(14,8), stopp(14,8), -1 - antel(14,8) = ane8 + antel(14,7) + ,8), stopp(14,8)) + do ane8 = start(14,8), stopp(14,8), -1 + antel(14,8) = ane8 + antel(14,7) if (.not.(antel(14,8)<=antal .and. ansats(& 14,7,1)<=2 .and. ansats(14,7,0)<=2)) & - cycle + cycle do pluse8 = min(ane8,18), max(ane8 - 16,0)& - , -1 - ansats(14,8,1) = pluse8 - ansats(14,8,0) = ane8 - pluse8 + , -1 + ansats(14,8,1) = pluse8 + ansats(14,8,0) = ane8 - pluse8 ! 14m call sluggo (14, 9, varmax, varupp, varned& , ansats, org, lock(14,9), low, start(14& - ,9), stopp(14,9)) - do ane9 = start(14,9), stopp(14,9), -1 - antel(14,9) = ane9 + antel(14,8) + ,9), stopp(14,9)) + do ane9 = start(14,9), stopp(14,9), -1 + antel(14,9) = ane9 + antel(14,8) if (.not.(antel(14,9)<=antal .and. ansats(& 14,8,1)<=2 .and. ansats(14,8,0)<=2)) & - cycle + cycle do pluse9 = min(ane9,20), max(ane9 - 18,0)& - , -1 - ansats(14,9,1) = pluse9 - ansats(14,9,0) = ane9 - pluse9 + , -1 + ansats(14,9,1) = pluse9 + ansats(14,9,0) = ane9 - pluse9 ! 14n call sluggo (14, 10, varmax, varupp, varned& , ansats, org, lock(14,10), low, start(& - 14,10), stopp(14,10)) - do anea = start(14,10), stopp(14,10), -1 - antel(14,10) = anea + antel(14,9) + 14,10), stopp(14,10)) + do anea = start(14,10), stopp(14,10), -1 + antel(14,10) = anea + antel(14,9) if (.not.(antel(14,10)<=antal .and. ansats(& 14,9,1)<=2 .and. ansats(14,9,0)<=2& - .and. antel(14,10)>=lim(14))) cycle + .and. antel(14,10)>=lim(14))) cycle do plusea = min(anea,22), max(anea - 20,0)& - , -1 - ansats(14,10,1) = plusea - ansats(14,10,0) = anea - plusea + , -1 + ansats(14,10,1) = plusea + ansats(14,10,0) = anea - plusea ! 15s call sluggo (15, 0, varmax, varupp, varned& , ansats, org, lock(15,0), low, start(15& - ,0), stopp(15,0)) - do anf0 = start(15,0), stopp(15,0), -1 - antel(15,0) = anf0 + antel(14,10) + ,0), stopp(15,0)) + do anf0 = start(15,0), stopp(15,0), -1 + antel(15,0) = anf0 + antel(14,10) if (.not.(antel(15,0)<=antal .and. ansats(& 14,10,1)<=2 .and. ansats(14,10,0)<=2)) & - cycle - ansats(15,0,0) = anf0 + cycle + ansats(15,0,0) = anf0 ! 15p call sluggo (15, 1, varmax, varupp, varned& , ansats, org, lock(15,1), low, start(15& - ,1), stopp(15,1)) - do anf1 = start(15,1), stopp(15,1), -1 - antel(15,1) = anf1 + antel(15,0) - if (antel(15,1) > antal) cycle + ,1), stopp(15,1)) + do anf1 = start(15,1), stopp(15,1), -1 + antel(15,1) = anf1 + antel(15,0) + if (antel(15,1) > antal) cycle do plusf1 = min(anf1,4), max(anf1 - 2,0), & - -1 - ansats(15,1,1) = plusf1 - ansats(15,1,0) = anf1 - plusf1 + -1 + ansats(15,1,1) = plusf1 + ansats(15,1,0) = anf1 - plusf1 ! 15d call sluggo (15, 2, varmax, varupp, varned& , ansats, org, lock(15,2), low, start(15& - ,2), stopp(15,2)) - do anf2 = start(15,2), stopp(15,2), -1 - antel(15,2) = anf2 + antel(15,1) - if (antel(15,2) > antal) cycle + ,2), stopp(15,2)) + do anf2 = start(15,2), stopp(15,2), -1 + antel(15,2) = anf2 + antel(15,1) + if (antel(15,2) > antal) cycle do plusf2 = min(anf2,6), max(anf2 - 4,0), & - -1 - ansats(15,2,1) = plusf2 - ansats(15,2,0) = anf2 - plusf2 + -1 + ansats(15,2,1) = plusf2 + ansats(15,2,0) = anf2 - plusf2 ! 15f call sluggo (15, 3, varmax, varupp, varned& , ansats, org, lock(15,3), low, start(15& - ,3), stopp(15,3)) - do anf3 = start(15,3), stopp(15,3), -1 - antel(15,3) = anf3 + antel(15,2) - if (antel(15,3) > antal) cycle + ,3), stopp(15,3)) + do anf3 = start(15,3), stopp(15,3), -1 + antel(15,3) = anf3 + antel(15,2) + if (antel(15,3) > antal) cycle do plusf3 = min(anf3,8), max(anf3 - 6,0), & - -1 - ansats(15,3,1) = plusf3 - ansats(15,3,0) = anf3 - plusf3 + -1 + ansats(15,3,1) = plusf3 + ansats(15,3,0) = anf3 - plusf3 ! 15g call sluggo (15, 4, varmax, varupp, varned& , ansats, org, lock(15,4), low, start(15& - ,4), stopp(15,4)) - do anf4 = start(15,4), stopp(15,4), -1 - antel(15,4) = anf4 + antel(15,3) - if (antel(15,4) > antal) cycle + ,4), stopp(15,4)) + do anf4 = start(15,4), stopp(15,4), -1 + antel(15,4) = anf4 + antel(15,3) + if (antel(15,4) > antal) cycle do plusf4 = min(anf4,10), max(anf4 - 8,0), & - -1 - ansats(15,4,1) = plusf4 - ansats(15,4,0) = anf4 - plusf4 + -1 + ansats(15,4,1) = plusf4 + ansats(15,4,0) = anf4 - plusf4 ! 15h call sluggo (15, 5, varmax, varupp, varned& , ansats, org, lock(15,5), low, start(15& - ,5), stopp(15,5)) - do anf5 = start(15,5), stopp(15,5), -1 - antel(15,5) = anf5 + antel(15,4) + ,5), stopp(15,5)) + do anf5 = start(15,5), stopp(15,5), -1 + antel(15,5) = anf5 + antel(15,4) if (antel(15,5)>antal .or. ansats(15,4,1)>2& - ) cycle + ) cycle do plusf5 = min(anf5,12), max(anf5 - 10,0)& - , -1 - ansats(15,5,1) = plusf5 - ansats(15,5,0) = anf5 - plusf5 + , -1 + ansats(15,5,1) = plusf5 + ansats(15,5,0) = anf5 - plusf5 ! 15i call sluggo (15, 6, varmax, varupp, varned& , ansats, org, lock(15,6), low, start(15& - ,6), stopp(15,6)) - do anf6 = start(15,6), stopp(15,6), -1 - antel(15,6) = anf6 + antel(15,5) + ,6), stopp(15,6)) + do anf6 = start(15,6), stopp(15,6), -1 + antel(15,6) = anf6 + antel(15,5) if (.not.(antel(15,6)<=antal .and. ansats(& 15,5,1)<=2 .and. ansats(15,5,0)<=2)) & - cycle + cycle do plusf6 = min(anf6,14), max(anf6 - 12,0)& - , -1 - ansats(15,6,1) = plusf6 - ansats(15,6,0) = anf6 - plusf6 + , -1 + ansats(15,6,1) = plusf6 + ansats(15,6,0) = anf6 - plusf6 ! 15k call sluggo (15, 7, varmax, varupp, varned& , ansats, org, lock(15,7), low, start(15& - ,7), stopp(15,7)) - do anf7 = start(15,7), stopp(15,7), -1 - antel(15,7) = anf7 + antel(15,6) + ,7), stopp(15,7)) + do anf7 = start(15,7), stopp(15,7), -1 + antel(15,7) = anf7 + antel(15,6) if (.not.(antel(15,7)<=antal .and. ansats(& 15,6,1)<=2 .and. ansats(15,6,0)<=2)) & - cycle + cycle do plusf7 = min(anf7,16), max(anf7 - 14,0)& - , -1 - ansats(15,7,1) = plusf7 - ansats(15,7,0) = anf7 - plusf7 + , -1 + ansats(15,7,1) = plusf7 + ansats(15,7,0) = anf7 - plusf7 ! 15l call sluggo (15, 8, varmax, varupp, varned& , ansats, org, lock(15,8), low, start(15& - ,8), stopp(15,8)) - do anf8 = start(15,8), stopp(15,8), -1 - antel(15,8) = anf8 + antel(15,7) + ,8), stopp(15,8)) + do anf8 = start(15,8), stopp(15,8), -1 + antel(15,8) = anf8 + antel(15,7) if (.not.(antel(15,8)<=antal .and. ansats(& 15,7,1)<=2 .and. ansats(15,7,0)<=2)) & - cycle + cycle do plusf8 = min(anf8,18), max(anf8 - 16,0)& - , -1 - ansats(15,8,1) = plusf8 - ansats(15,8,0) = anf8 - plusf8 + , -1 + ansats(15,8,1) = plusf8 + ansats(15,8,0) = anf8 - plusf8 ! 15m call sluggo (15, 9, varmax, varupp, varned& , ansats, org, lock(15,9), low, start(15& - ,9), stopp(15,9)) - do anf9 = start(15,9), stopp(15,9), -1 - antel(15,9) = anf9 + antel(15,8) + ,9), stopp(15,9)) + do anf9 = start(15,9), stopp(15,9), -1 + antel(15,9) = anf9 + antel(15,8) if (.not.(antel(15,9)<=antal .and. ansats(& 15,8,1)<=2 .and. ansats(15,8,0)<=2)) & - cycle + cycle do plusf9 = min(anf9,20), max(anf9 - 18,0)& - , -1 - ansats(15,9,1) = plusf9 - ansats(15,9,0) = anf9 - plusf9 + , -1 + ansats(15,9,1) = plusf9 + ansats(15,9,0) = anf9 - plusf9 ! 15n call sluggo (15, 10, varmax, varupp, varned& , ansats, org, lock(15,10), low, start(& - 15,10), stopp(15,10)) - do anfa = start(15,10), stopp(15,10), -1 - antel(15,10) = anfa + antel(15,9) + 15,10), stopp(15,10)) + do anfa = start(15,10), stopp(15,10), -1 + antel(15,10) = anfa + antel(15,9) if (.not.(antel(15,10)==antal .and. ansats(& 15,9,1)<=2 .and. ansats(15,9,0)<=2)) & - cycle + cycle do plusfa = min(anfa,22), max(anfa - 20,0)& - , -1 - ansats(15,10,1) = plusfa - ansats(15,10,0) = anfa - plusfa + , -1 + ansats(15,10,1) = plusfa + ansats(15,10,0) = anfa - plusfa if (ansats(15,10,1)>2 .or. ansats(15,10,0)>& - 2) cycle - par = 0 - elar = 0 - do i = 1, nmax - do j = 0, min(10,i - 1) - elar = elar + (ansats(i,j,0)+ansats(i,j,1)) + 2) cycle + par = 0 + elar = 0 + do i = 1, nmax + do j = 0, min(10,i - 1) + elar = elar + (ansats(i,j,0)+ansats(i,j,1)) par = mod(par + j*(ansats(i,j,0)+ansats(i,j& - ,1)),2) - end do - end do - if (par /= par0) cycle - if (elar /= antal) write (*, *) 'FEL' - cf = cf + 1 - do i = 1, 15 + ,1)),2) + end do + end do + if (par /= par0) cycle + if (elar /= antal) write (*, *) 'FEL' + cf = cf + 1 + do i = 1, 15 write (fil, 5000) (ansats(i,j,0),j=0,min(10& - ,i - 1)) + ,i - 1)) write (fil, 5000) (ansats(i,j,1),j=0,min(10& - ,i - 1)) - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - end do - 5000 format(11i2) - return - end subroutine blandb + ,i - 1)) + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + end do + 5000 format(11i2) + return + end subroutine blandb diff --git a/src/appl/rcsfgenerate90/blandb_I.f90 b/src/appl/rcsfgenerate90/blandb_I.f90 index f2cb09e01..5d2bed238 100644 --- a/src/appl/rcsfgenerate90/blandb_I.f90 +++ b/src/appl/rcsfgenerate90/blandb_I.f90 @@ -1,23 +1,23 @@ - MODULE blandb_I + MODULE blandb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blandb (ORG, NMAX, VARMAX, LOCK, FIL, LOW, LIM, POSN, POSL& - , MINJ, MAXJ) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - integer, INTENT(IN) :: NMAX - integer :: VARMAX - logical, DIMENSION(15,0:10) :: LOCK - integer, INTENT(IN) :: FIL - integer, DIMENSION(15,0:10) :: LOW - integer, DIMENSION(15), INTENT(IN) :: LIM - integer, DIMENSION(110) :: POSN + , MINJ, MAXJ) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + integer, INTENT(IN) :: NMAX + integer :: VARMAX + logical, DIMENSION(15,0:10) :: LOCK + integer, INTENT(IN) :: FIL + integer, DIMENSION(15,0:10) :: LOW + integer, DIMENSION(15), INTENT(IN) :: LIM + integer, DIMENSION(110) :: POSN !VAST...Dummy argument POSN is not referenced in this routine. - integer, DIMENSION(110) :: POSL + integer, DIMENSION(110) :: POSL !VAST...Dummy argument POSL is not referenced in this routine. - integer :: MINJ + integer :: MINJ !VAST...Dummy argument MINJ is not referenced in this routine. - integer :: MAXJ + integer :: MAXJ !VAST...Dummy argument MAXJ is not referenced in this routine. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/blandc.f90 b/src/appl/rcsfgenerate90/blandc.f90 index 436c06e42..7d171447a 100644 --- a/src/appl/rcsfgenerate90/blandc.f90 +++ b/src/appl/rcsfgenerate90/blandc.f90 @@ -1,281 +1,281 @@ ! last edited August 1, 1996 subroutine blandc(varmax, cfmax, lock, med, minj, maxj, nmax, posn, posl& - , lim) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + , lim) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use blandb_I - use mergeb_I - use gen_I + use blandb_I + use mergeb_I + use gen_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer , intent(in) :: cfmax - integer :: minj - integer :: maxj - integer :: nmax - integer :: posn(110) - integer :: posl(110) - integer :: lim(15) - logical :: lock(15,0:10) - logical , intent(in) :: med(15,0:10) + integer :: varmax + integer , intent(in) :: cfmax + integer :: minj + integer :: maxj + integer :: nmax + integer :: posn(110) + integer :: posl(110) + integer :: lim(15) + logical :: lock(15,0:10) + logical , intent(in) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: cf - integer , dimension(15,0:10) :: org - integer :: i, j, n, k, l, l1, antal, tal, antalc - integer , dimension(15,0:10) :: low - integer :: tot - integer , dimension(15000,15,0:10) :: lista - integer , dimension(15,0:10,0:1) :: ansats - integer :: par, start, stopp, skal, duplet, kvar - logical :: finns - logical, dimension(15000) :: lik - character :: rad*500 - character, dimension(0:10) :: orb + integer :: cf + integer , dimension(15,0:10) :: org + integer :: i, j, n, k, l, l1, antal, tal, antalc + integer , dimension(15,0:10) :: low + integer :: tot + integer , dimension(15000,15,0:10) :: lista + integer , dimension(15,0:10,0:1) :: ansats + integer :: par, start, stopp, skal, duplet, kvar + logical :: finns + logical, dimension(15000) :: lik + character :: rad*500 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - cf = 0 - antalc = 0 - tot = 0 - skal = 20 - finns = .FALSE. - do i = 1, 15 - org(i,:min(10,i-1)) = 0 - low(i,:min(10,i-1)) = 0 - end do - open(unit=7, status='scratch', position='asis') - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - read (fil_2, 1000) - do i = 1, 500 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (.not.(med(i,j) .or. .not.lock(i,j))) cycle - start = start + 5 - stopp = stopp + 5 - rad(start:start) = char(ichar('0') + i) - rad(start+1:start+1) = orb(j) - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - rad(start:start) = char(ichar('0') + i) - rad(start+1:start+1) = orb(j) - end do - write (fil_1, 1000) rad - read (fil_2, 1000) rad - write (fil_1, 1000) rad - 2 continue - read (fil_2, 1000, end=200) rad - read (fil_2, 1000, end=200) - read (fil_2, 1000, end=200) - tot = tot + 1 - do i = 1, 15 - lista(tot,i,:min(10,i-1)) = 0 - end do - do i = 1, skal - n = 9*(i - 1) + 3 - l = n + 1 - tal = ichar(rad(n:n)) - ichar('0') - if (tal>=1 .and. tal<=15) then - l1 = -1 - do j = 0, tal - 1 - if (orb(j) /= rad(l:l)) cycle - l1 = j - end do - if (l1 == (-1)) exit - else - exit - endif - antal = ichar(rad(l+3:l+3)) - ichar('0') - if (antal>=0 .and. antal<=9) then - antal = antal*10 - else - antal = 0 - endif - antal = antal + ichar(rad(l+4:l+4)) - ichar('0') - lista(tot,tal,l1) = lista(tot,tal,l1) + antal - end do - go to 2 - 200 continue - if (tot == 0) then - write (*, 1005) 'Nothing in inputfile!' - stop - endif - if (tot < 10) then - write (*, 2001) 'Number of csf:s in inputfile = ', tot - else if (tot < 100) then - write (*, 2002) 'Number of csf:s in inputfile = ', tot - else if (tot < 1000) then - write (*, 2003) 'Number of csf:s in inputfile = ', tot - else if (tot < 10000) then - write (*, 2004) 'Number of csf:s in inputfile = ', tot - else - write (*, 2005) 'Number of csf:s in inputfile = ', tot - endif - duplet = 0 - lik(:tot) = .FALSE. - if (tot >= 2) then - do i = 1, tot - 1 - if (lik(i)) cycle - l302: do j = i + 1, tot - if (lik(j)) cycle l302 - do k = 1, nmax - do l = 0, min(10,k - 1) - if (lista(i,k,l) == lista(j,k,l)) cycle - cycle l302 - end do - end do - lik(j) = .TRUE. - end do l302 - end do - endif - duplet = duplet + count(lik(:tot)) - if (duplet < 10) then - write (*, 2001) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 100) then - write (*, 2002) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 1000) then - write (*, 2003) 'Number of duplicat csf:s in file = ', duplet - else if (duplet < 10000) then - write (*, 2004) 'Number of duplicat csf:s in file = ', duplet - else - write (*, 2005) 'Number of duplicat csf:s in file = ', duplet - endif - kvar = tot - duplet - write (*, *) - do i = 1, tot - if (.not.lik(i)) then - if (kvar > 1) then - if (kvar < 10) then - write (*, 1001) kvar, ' csf:s still to be expanded.' - else if (kvar < 100) then - write (*, 1002) kvar, ' csf:s still to be expanded.' - else if (kvar < 1000) then - write (*, 1003) kvar, ' csf:s still to be expanded.' - else if (kvar < 10000) then - write (*, 1004) kvar, ' csf:s still to be expanded.' - else - write (*, 1006) kvar, ' csf:s still to be expanded.' - endif - else - write (*, 1005) 'The last csf is still to be expanded.' - endif - kvar = kvar - 1 - par = 0 - do k = 1, nmax - org(k,:min(k-1,10)) = lista(i,k,:min(k-1,10)) - end do - if (finns) then - open(unit=21, status='scratch', position='asis') + 'n'/ + cf = 0 + antalc = 0 + tot = 0 + skal = 20 + finns = .FALSE. + do i = 1, 15 + org(i,:min(10,i-1)) = 0 + low(i,:min(10,i-1)) = 0 + end do + open(unit=7, status='scratch', position='asis') + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + read (fil_2, 1000) + do i = 1, 500 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (.not.(med(i,j) .or. .not.lock(i,j))) cycle + start = start + 5 + stopp = stopp + 5 + rad(start:start) = char(ichar('0') + i) + rad(start+1:start+1) = orb(j) + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + rad(start:start) = char(ichar('0') + i) + rad(start+1:start+1) = orb(j) + end do + write (fil_1, 1000) rad + read (fil_2, 1000) rad + write (fil_1, 1000) rad + 2 continue + read (fil_2, 1000, end=200) rad + read (fil_2, 1000, end=200) + read (fil_2, 1000, end=200) + tot = tot + 1 + do i = 1, 15 + lista(tot,i,:min(10,i-1)) = 0 + end do + do i = 1, skal + n = 9*(i - 1) + 3 + l = n + 1 + tal = ichar(rad(n:n)) - ichar('0') + if (tal>=1 .and. tal<=15) then + l1 = -1 + do j = 0, tal - 1 + if (orb(j) /= rad(l:l)) cycle + l1 = j + end do + if (l1 == (-1)) exit + else + exit + endif + antal = ichar(rad(l+3:l+3)) - ichar('0') + if (antal>=0 .and. antal<=9) then + antal = antal*10 + else + antal = 0 + endif + antal = antal + ichar(rad(l+4:l+4)) - ichar('0') + lista(tot,tal,l1) = lista(tot,tal,l1) + antal + end do + go to 2 + 200 continue + if (tot == 0) then + write (*, 1005) 'Nothing in inputfile!' + stop + endif + if (tot < 10) then + write (*, 2001) 'Number of csf:s in inputfile = ', tot + else if (tot < 100) then + write (*, 2002) 'Number of csf:s in inputfile = ', tot + else if (tot < 1000) then + write (*, 2003) 'Number of csf:s in inputfile = ', tot + else if (tot < 10000) then + write (*, 2004) 'Number of csf:s in inputfile = ', tot + else + write (*, 2005) 'Number of csf:s in inputfile = ', tot + endif + duplet = 0 + lik(:tot) = .FALSE. + if (tot >= 2) then + do i = 1, tot - 1 + if (lik(i)) cycle + l302: do j = i + 1, tot + if (lik(j)) cycle l302 + do k = 1, nmax + do l = 0, min(10,k - 1) + if (lista(i,k,l) == lista(j,k,l)) cycle + cycle l302 + end do + end do + lik(j) = .TRUE. + end do l302 + end do + endif + duplet = duplet + count(lik(:tot)) + if (duplet < 10) then + write (*, 2001) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 100) then + write (*, 2002) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 1000) then + write (*, 2003) 'Number of duplicat csf:s in file = ', duplet + else if (duplet < 10000) then + write (*, 2004) 'Number of duplicat csf:s in file = ', duplet + else + write (*, 2005) 'Number of duplicat csf:s in file = ', duplet + endif + kvar = tot - duplet + write (*, *) + do i = 1, tot + if (.not.lik(i)) then + if (kvar > 1) then + if (kvar < 10) then + write (*, 1001) kvar, ' csf:s still to be expanded.' + else if (kvar < 100) then + write (*, 1002) kvar, ' csf:s still to be expanded.' + else if (kvar < 1000) then + write (*, 1003) kvar, ' csf:s still to be expanded.' + else if (kvar < 10000) then + write (*, 1004) kvar, ' csf:s still to be expanded.' + else + write (*, 1006) kvar, ' csf:s still to be expanded.' + endif + else + write (*, 1005) 'The last csf is still to be expanded.' + endif + kvar = kvar - 1 + par = 0 + do k = 1, nmax + org(k,:min(k-1,10)) = lista(i,k,:min(k-1,10)) + end do + if (finns) then + open(unit=21, status='scratch', position='asis') call blandb (org, nmax, varmax, lock, 21, low, lim, posn, posl, & - minj, maxj) - rewind (21) - call mergeb (antalc) - if (antalc < 10) then - write (*, 2001) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 100) then - write (*, 2002) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 1000) then - write (*, 2003) 'Number of uncoupled csf:s = ', antalc - else if (antalc < 10000) then - write (*, 2004) 'Number of uncoupled csf:s = ', antalc - else - write (*, 2005) 'Number of uncoupled csf:s = ', antalc - endif - else - open(unit=20, status='scratch', position='asis') + minj, maxj) + rewind (21) + call mergeb (antalc) + if (antalc < 10) then + write (*, 2001) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 100) then + write (*, 2002) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 1000) then + write (*, 2003) 'Number of uncoupled csf:s = ', antalc + else if (antalc < 10000) then + write (*, 2004) 'Number of uncoupled csf:s = ', antalc + else + write (*, 2005) 'Number of uncoupled csf:s = ', antalc + endif + else + open(unit=20, status='scratch', position='asis') call blandb (org, nmax, varmax, lock, 20, low, lim, posn, posl, & - minj, maxj) - rewind (20) - finns = .TRUE. - antalc = 0 - write (*, 1005) 'The first configuration has been expanded.' - endif - if (antalc >= cfmax) then - write (*, 1005) 'Maximum number of uncoupled csf:s exceeded' - exit - endif - endif - end do - write (*, *) - write (*, 1005) 'Preparing the couplings of the csf:s.' - - if (nmax < 15) then - do i = nmax + 1, 15 - ansats(i,:min(10,i-1),0) = 0 - ansats(i,:min(10,i-1),1) = 0 - end do - endif - cf = 0 - 490 continue - do i = 1, 15 - read (20, 5000, end=492) (ansats(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=492) (ansats(i,j,1),j=0,min(10,i - 1)) - end do - par = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, min(j,1) - par = mod(par + j*ansats(i,j,k),2) - end do - end do - end do - call gen (ansats, posn, posl, skal, cf, .TRUE., minj, maxj, par) - go to 490 - 492 continue - rewind (fil_1) - if (cf == 0) then - write (*, 1005) 'No configuration state has been generated.' - else if (cf == 1) then - write (*, 1005) 'One configuration state has been generated.' - else if (cf < 10) then - write (*, 1001) cf, ' configuration states have been generated.' - else if (cf < 100) then - write (*, 1002) cf, ' configuration states have been generated.' - else if (cf < 1000) then - write (*, 1003) cf, ' configuration states have been generated.' - else if (cf < 10000) then - write (*, 1004) cf, ' configuration states have been generated.' - else if (cf < 100000) then - write (*, 1006) cf, ' configuration states have been generated.' - else - write (*, *) cf, ' configuration states have been generated.' - endif - 1000 format(a) - 1001 format(' ',i1,a) - 1002 format(' ',i2,a) - 1003 format(' ',i3,a) - 1004 format(' ',i4,a) - 1005 format(' ',a) - 1006 format(' ',i5,a) - 2001 format(' ',a,i1,'.') - 2002 format(' ',a,i2,'.') - 2003 format(' ',a,i3,'.') - 2004 format(' ',a,i4,'.') - 2005 format(' ',a,i5,'.') - - 5000 format(11i2) - return - end subroutine blandc + minj, maxj) + rewind (20) + finns = .TRUE. + antalc = 0 + write (*, 1005) 'The first configuration has been expanded.' + endif + if (antalc >= cfmax) then + write (*, 1005) 'Maximum number of uncoupled csf:s exceeded' + exit + endif + endif + end do + write (*, *) + write (*, 1005) 'Preparing the couplings of the csf:s.' + + if (nmax < 15) then + do i = nmax + 1, 15 + ansats(i,:min(10,i-1),0) = 0 + ansats(i,:min(10,i-1),1) = 0 + end do + endif + cf = 0 + 490 continue + do i = 1, 15 + read (20, 5000, end=492) (ansats(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=492) (ansats(i,j,1),j=0,min(10,i - 1)) + end do + par = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, min(j,1) + par = mod(par + j*ansats(i,j,k),2) + end do + end do + end do + call gen (ansats, posn, posl, skal, cf, .TRUE., minj, maxj, par) + go to 490 + 492 continue + rewind (fil_1) + if (cf == 0) then + write (*, 1005) 'No configuration state has been generated.' + else if (cf == 1) then + write (*, 1005) 'One configuration state has been generated.' + else if (cf < 10) then + write (*, 1001) cf, ' configuration states have been generated.' + else if (cf < 100) then + write (*, 1002) cf, ' configuration states have been generated.' + else if (cf < 1000) then + write (*, 1003) cf, ' configuration states have been generated.' + else if (cf < 10000) then + write (*, 1004) cf, ' configuration states have been generated.' + else if (cf < 100000) then + write (*, 1006) cf, ' configuration states have been generated.' + else + write (*, *) cf, ' configuration states have been generated.' + endif + 1000 format(a) + 1001 format(' ',i1,a) + 1002 format(' ',i2,a) + 1003 format(' ',i3,a) + 1004 format(' ',i4,a) + 1005 format(' ',a) + 1006 format(' ',i5,a) + 2001 format(' ',a,i1,'.') + 2002 format(' ',a,i2,'.') + 2003 format(' ',a,i3,'.') + 2004 format(' ',a,i4,'.') + 2005 format(' ',a,i5,'.') + + 5000 format(11i2) + return + end subroutine blandc diff --git a/src/appl/rcsfgenerate90/blandc_I.f90 b/src/appl/rcsfgenerate90/blandc_I.f90 index 403886c39..56162d21a 100644 --- a/src/appl/rcsfgenerate90/blandc_I.f90 +++ b/src/appl/rcsfgenerate90/blandc_I.f90 @@ -1,18 +1,18 @@ - MODULE blandc_I + MODULE blandc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE blandc (VARMAX, CFMAX, LOCK, MED, MINJ, MAXJ, NMAX, POSN, POSL& - , LIM) - integer :: VARMAX - integer, INTENT(IN) :: CFMAX - logical, DIMENSION(15,0:10), INTENT(IN) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: MED - integer :: MINJ - integer :: MAXJ - integer, INTENT(IN) :: NMAX - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL - integer, DIMENSION(15) :: LIM - END SUBROUTINE - END INTERFACE - END MODULE + , LIM) + integer :: VARMAX + integer, INTENT(IN) :: CFMAX + logical, DIMENSION(15,0:10), INTENT(IN) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: MED + integer :: MINJ + integer :: MAXJ + integer, INTENT(IN) :: NMAX + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL + integer, DIMENSION(15) :: LIM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/copy7t9.f90 b/src/appl/rcsfgenerate90/copy7t9.f90 index b1e1f00ab..882f24b5f 100644 --- a/src/appl/rcsfgenerate90/copy7t9.f90 +++ b/src/appl/rcsfgenerate90/copy7t9.f90 @@ -1,27 +1,27 @@ - subroutine copy7t9 -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine copy7t9 +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: utfil = 9 + integer, parameter :: fil_1 = 7 + integer, parameter :: utfil = 9 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - character :: rad11*1000 + character :: rad11*1000 !----------------------------------------------- - open(fil_1, file='rcsf.out', status='unknown', position='asis') - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - do while(.TRUE.) - read (utfil, 999, end=100) rad11 - write (fil_1, 999) trim(rad11) - end do - 100 continue - close(utfil, status='delete') - close(fil_1) - return - 999 format(a) - return - end subroutine copy7t9 + open(fil_1, file='rcsf.out', status='unknown', position='asis') + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + do while(.TRUE.) + read (utfil, 999, end=100) rad11 + write (fil_1, 999) trim(rad11) + end do + 100 continue + close(utfil, status='delete') + close(fil_1) + return + 999 format(a) + return + end subroutine copy7t9 diff --git a/src/appl/rcsfgenerate90/copy7t9_I.f90 b/src/appl/rcsfgenerate90/copy7t9_I.f90 index ec47a96e6..914d8f981 100644 --- a/src/appl/rcsfgenerate90/copy7t9_I.f90 +++ b/src/appl/rcsfgenerate90/copy7t9_I.f90 @@ -1,8 +1,8 @@ - MODULE copy7t9_I + MODULE copy7t9_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE copy7t9 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE copy7t9 !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/fivefirst.f90 b/src/appl/rcsfgenerate90/fivefirst.f90 index ae69f98ef..1daf56b72 100644 --- a/src/appl/rcsfgenerate90/fivefirst.f90 +++ b/src/appl/rcsfgenerate90/fivefirst.f90 @@ -1,163 +1,163 @@ ! last edited Februar 20, 1996 - subroutine fivefirst(slut1, slut2, posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine fivefirst(slut1, slut2, posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(inout) :: slut1 - logical , intent(inout) :: slut2 - integer , intent(in) :: posn(110) - integer , intent(in) :: posl(110) + logical , intent(inout) :: slut1 + logical , intent(inout) :: slut2 + integer , intent(in) :: posn(110) + integer , intent(in) :: posl(110) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: k, i, j, n, l, pos, stopp - logical, dimension(15,0:10,0:1) :: med - character :: rad0*1000, rad1*1000, rad2*1000 - character, dimension(0:10) :: orb + integer :: k, i, j, n, l, pos, stopp + logical, dimension(15,0:10,0:1) :: med + character :: rad0*1000, rad1*1000, rad2*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ + 'n'/ !----------------------------------------------- - read (7, 999, end=100) - write (9, 999) 'Core subshells:' - read (7, 999, end=101) rad0 - stopp = 0 - do i = 0, 210 + read (7, 999, end=100) + write (9, 999) 'Core subshells:' + read (7, 999, end=101) rad0 + stopp = 0 + do i = 0, 210 if (ichar(rad0(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad0(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad0(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'Peel subshells:' - read (7, 999, end=102) - read (7, 999, end=102) rad1 - read (7, 999, end=102) - if (.not.slut2) then - read (8, 999, end=90) - read (8, 999, end=90) - read (8, 999, end=90) - read (8, 999, end=90) rad2 - read (8, 999, end=90) - do i = 1, 15 - med(i,:min(10,i-1),0) = .FALSE. - med(i,:min(10,i-1),1) = .FALSE. - end do - do i = 1, 205 - pos = 5*i - n = ichar(rad1(pos-2:pos-2)) - ichar('0') - if (rad1(pos-3:pos-3) == '1') n = n + 10 - l = -1 - if (n>=1 .and. n<=15) then - do j = 0, min(10,n - 1) - if (rad1(pos-1:pos-1) /= orb(j)) cycle - l = j - end do - endif - if (l == (-1)) exit - if (rad1(pos:pos)=='-' .or. l==0) then - med(n,l,0) = .TRUE. - else - med(n,l,1) = .TRUE. - endif - end do - do i = 1, 205 - pos = 5*i - n = ichar(rad2(pos-2:pos-2)) - ichar('0') - if (rad2(pos-3:pos-3) == '1') n = n + 10 - l = -1 - if (n>=1 .and. n<=15) then - do j = 0, min(10,n - 1) - if (rad2(pos-1:pos-1) /= orb(j)) cycle - l = j - end do - endif - if (l == (-1)) exit - if (rad2(pos:pos)=='-' .or. l==0) then - med(n,l,0) = .TRUE. - else - med(n,l,1) = .TRUE. - endif - end do - pos = 3 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (med(i,j,0)) then - rad0(pos-2:pos+2) = ' ' - if (i < 10) then - rad0(pos:pos) = char(i + ichar('0')) - else - rad0(pos:pos) = char(i + ichar('0') - 10) - rad0(pos-1:pos-1) = '1' - endif - rad0(pos+1:pos+1) = orb(j) - if (j /= 0) rad0(pos+2:pos+2) = '-' - pos = pos + 5 - endif - if (.not.med(i,j,1)) cycle - rad0(pos-2:pos+2) = ' ' - if (i < 10) then - rad0(pos:pos) = char(i + ichar('0')) - else - rad0(pos:pos) = char(i + ichar('0') - 10) - rad0(pos-1:pos-1) = '1' - endif - rad0(pos+1:pos+1) = orb(j) - pos = pos + 5 - end do - write (9, 999) rad0(1:pos-3) - write (9, 999) 'CSF(s):' - return - endif - 90 continue - slut2 = .TRUE. - stopp = 0 - do i = 0, 210 + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad0(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'Peel subshells:' + read (7, 999, end=102) + read (7, 999, end=102) rad1 + read (7, 999, end=102) + if (.not.slut2) then + read (8, 999, end=90) + read (8, 999, end=90) + read (8, 999, end=90) + read (8, 999, end=90) rad2 + read (8, 999, end=90) + do i = 1, 15 + med(i,:min(10,i-1),0) = .FALSE. + med(i,:min(10,i-1),1) = .FALSE. + end do + do i = 1, 205 + pos = 5*i + n = ichar(rad1(pos-2:pos-2)) - ichar('0') + if (rad1(pos-3:pos-3) == '1') n = n + 10 + l = -1 + if (n>=1 .and. n<=15) then + do j = 0, min(10,n - 1) + if (rad1(pos-1:pos-1) /= orb(j)) cycle + l = j + end do + endif + if (l == (-1)) exit + if (rad1(pos:pos)=='-' .or. l==0) then + med(n,l,0) = .TRUE. + else + med(n,l,1) = .TRUE. + endif + end do + do i = 1, 205 + pos = 5*i + n = ichar(rad2(pos-2:pos-2)) - ichar('0') + if (rad2(pos-3:pos-3) == '1') n = n + 10 + l = -1 + if (n>=1 .and. n<=15) then + do j = 0, min(10,n - 1) + if (rad2(pos-1:pos-1) /= orb(j)) cycle + l = j + end do + endif + if (l == (-1)) exit + if (rad2(pos:pos)=='-' .or. l==0) then + med(n,l,0) = .TRUE. + else + med(n,l,1) = .TRUE. + endif + end do + pos = 3 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (med(i,j,0)) then + rad0(pos-2:pos+2) = ' ' + if (i < 10) then + rad0(pos:pos) = char(i + ichar('0')) + else + rad0(pos:pos) = char(i + ichar('0') - 10) + rad0(pos-1:pos-1) = '1' + endif + rad0(pos+1:pos+1) = orb(j) + if (j /= 0) rad0(pos+2:pos+2) = '-' + pos = pos + 5 + endif + if (.not.med(i,j,1)) cycle + rad0(pos-2:pos+2) = ' ' + if (i < 10) then + rad0(pos:pos) = char(i + ichar('0')) + else + rad0(pos:pos) = char(i + ichar('0') - 10) + rad0(pos-1:pos-1) = '1' + endif + rad0(pos+1:pos+1) = orb(j) + pos = pos + 5 + end do + write (9, 999) rad0(1:pos-3) + write (9, 999) 'CSF(s):' + return + endif + 90 continue + slut2 = .TRUE. + stopp = 0 + do i = 0, 210 if (ichar(rad1(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad1(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad1(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'CSF(s):' - return - 100 continue - slut1 = .TRUE. - write (9, 999) 'Core subshells:' - read (8, 999, end=200) rad0 - 101 continue - if (.not.slut1) then - slut1 = .TRUE. - read (8, 999, end=200) rad0 - endif - stopp = 0 - do i = 0, 210 + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad1(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'CSF(s):' + return + 100 continue + slut1 = .TRUE. + write (9, 999) 'Core subshells:' + read (8, 999, end=200) rad0 + 101 continue + if (.not.slut1) then + slut1 = .TRUE. + read (8, 999, end=200) rad0 + endif + stopp = 0 + do i = 0, 210 if (ichar(rad0(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad0(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then !PJ write(9,999) rad1(1:stopp) do i = 1,1000 if (rad1(i:i).eq.':') rad1(i-1:i) = '10' @@ -170,36 +170,36 @@ subroutine fivefirst(slut1, slut2, posn, posl) write(9,999) trim(rad1) !PJ -! write (9, 999) rad0(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'Peel subshells:' - 102 continue - if (.not.slut1) then - slut1 = .TRUE. - read (8, 999, end=200) - read (8, 999, end=200) rad2 - endif - stopp = 0 - do i = 0, 210 +! write (9, 999) rad0(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'Peel subshells:' + 102 continue + if (.not.slut1) then + slut1 = .TRUE. + read (8, 999, end=200) + read (8, 999, end=200) rad2 + endif + stopp = 0 + do i = 0, 210 if (ichar(rad2(stopp+3:stopp+3))>=ichar('0') .and. ichar(rad2(stopp+3:& - stopp+3))<=ichar('9')) then - stopp = stopp + 5 - else - exit - endif - end do - if (stopp /= 0) then - write (9, 999) rad2(1:stopp) - else - write (9, 999) - endif - write (9, 999) 'CSF(s):' - return - 200 continue - slut2 = .TRUE. - return - 999 format(a) - return - end subroutine fivefirst + stopp+3))<=ichar('9')) then + stopp = stopp + 5 + else + exit + endif + end do + if (stopp /= 0) then + write (9, 999) rad2(1:stopp) + else + write (9, 999) + endif + write (9, 999) 'CSF(s):' + return + 200 continue + slut2 = .TRUE. + return + 999 format(a) + return + end subroutine fivefirst diff --git a/src/appl/rcsfgenerate90/fivefirst_I.f90 b/src/appl/rcsfgenerate90/fivefirst_I.f90 index 87753ac17..683b2e46b 100644 --- a/src/appl/rcsfgenerate90/fivefirst_I.f90 +++ b/src/appl/rcsfgenerate90/fivefirst_I.f90 @@ -1,12 +1,12 @@ - MODULE fivefirst_I + MODULE fivefirst_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE fivefirst (SLUT1, SLUT2, POSN, POSL) - logical, INTENT(INOUT) :: SLUT1 - logical, INTENT(INOUT) :: SLUT2 - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE fivefirst (SLUT1, SLUT2, POSN, POSL) + logical, INTENT(INOUT) :: SLUT1 + logical, INTENT(INOUT) :: SLUT2 + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/fivelines.f90 b/src/appl/rcsfgenerate90/fivelines.f90 index e2fc8d69f..194644904 100644 --- a/src/appl/rcsfgenerate90/fivelines.f90 +++ b/src/appl/rcsfgenerate90/fivelines.f90 @@ -1,121 +1,121 @@ ! last edited July 30, 1996 - subroutine fivelines(org, locked, closed, first, posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine fivelines(org, locked, closed, first, posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(in) :: first - integer , intent(inout) :: org(15,0:10) - integer , intent(in) :: posn(110) - integer , intent(in) :: posl(110) - logical , intent(in) :: locked(15,0:10) - logical , intent(in) :: closed(15,0:10) + logical , intent(in) :: first + integer , intent(inout) :: org(15,0:10) + integer , intent(in) :: posn(110) + integer , intent(in) :: posl(110) + logical , intent(in) :: locked(15,0:10) + logical , intent(in) :: closed(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: k, i, j, start, stopp - character :: rad*1000 - character, dimension(0:10) :: orb + integer :: k, i, j, start, stopp + character :: rad*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - if (.not.first) then + 'n'/ + if (.not.first) then ! open(unit=8,file='fil2.dat',status='unknown') - open(unit=8, status='scratch', position='asis') - write (8, 999) - write (8, 999) - write (8, 999) - else - open(unit=7, file='fil1.dat', status='unknown', position='asis') + open(unit=8, status='scratch', position='asis') + write (8, 999) + write (8, 999) + write (8, 999) + else + open(unit=7, file='fil1.dat', status='unknown', position='asis') ! open(unit=7,status='scratch') - write (7, 999) 'Core subshells:' - do i = 1, 1000 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) - if (.not.closed(i,j)) cycle - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - org(i,j) = 0 - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - end do - if (stopp == 0) then - write (7, 999) - else - write (7, 999) rad(1:stopp) - endif - write (7, 999) 'Peel subshells:' - endif - do i = 1, 1000 - rad(i:i) = ' ' - end do - start = -2 - stopp = 0 - do k = 1, 110 - i = posn(k) - j = posl(k) + write (7, 999) 'Core subshells:' + do i = 1, 1000 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) + if (.not.closed(i,j)) cycle + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + org(i,j) = 0 + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + end do + if (stopp == 0) then + write (7, 999) + else + write (7, 999) rad(1:stopp) + endif + write (7, 999) 'Peel subshells:' + endif + do i = 1, 1000 + rad(i:i) = ' ' + end do + start = -2 + stopp = 0 + do k = 1, 110 + i = posn(k) + j = posl(k) if (.not.(.not.(org(i,j)==0 .and. locked(i,j)) .and. .not.closed(i,j))& - ) cycle - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) - if (j < 1) cycle - rad(start+2:start+2) = '-' - start = start + 5 - stopp = stopp + 5 - if (i < 10) then - rad(start:start) = char(ichar('0') + i) - else - rad(start-1:start-1) = '1' - rad(start:start) = char(ichar('0') + i - 10) - endif - rad(start+1:start+1) = orb(j) + ) cycle + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) + if (j < 1) cycle + rad(start+2:start+2) = '-' + start = start + 5 + stopp = stopp + 5 + if (i < 10) then + rad(start:start) = char(ichar('0') + i) + else + rad(start-1:start-1) = '1' + rad(start:start) = char(ichar('0') + i - 10) + endif + rad(start+1:start+1) = orb(j) ! write(*,*) i,rad(1:100) - end do - if (first) then - if (stopp == 0) then - write (7, 999) - else - write (7, 999) rad(1:stopp) - endif - write (7, 999) 'CSF(s):' - else - if (stopp == 0) then - write (8, 999) - else - write (8, 999) rad(1:stopp) - endif - write (8, 999) 'CSF(s):' - endif - 999 format(a) - return - end subroutine fivelines + end do + if (first) then + if (stopp == 0) then + write (7, 999) + else + write (7, 999) rad(1:stopp) + endif + write (7, 999) 'CSF(s):' + else + if (stopp == 0) then + write (8, 999) + else + write (8, 999) rad(1:stopp) + endif + write (8, 999) 'CSF(s):' + endif + 999 format(a) + return + end subroutine fivelines diff --git a/src/appl/rcsfgenerate90/fivelines_I.f90 b/src/appl/rcsfgenerate90/fivelines_I.f90 index c4ffd0ea6..0248866d6 100644 --- a/src/appl/rcsfgenerate90/fivelines_I.f90 +++ b/src/appl/rcsfgenerate90/fivelines_I.f90 @@ -1,14 +1,14 @@ - MODULE fivelines_I + MODULE fivelines_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE fivelines (ORG, LOCKED, CLOSED, FIRST, POSN, POSL) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - logical, DIMENSION(15,0:10), INTENT(IN) :: LOCKED - logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - logical, INTENT(IN) :: FIRST - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE fivelines (ORG, LOCKED, CLOSED, FIRST, POSN, POSL) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + logical, DIMENSION(15,0:10), INTENT(IN) :: LOCKED + logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + logical, INTENT(IN) :: FIRST + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/gen_I.f90 b/src/appl/rcsfgenerate90/gen_I.f90 index 7f3af08fc..532bcf82a 100644 --- a/src/appl/rcsfgenerate90/gen_I.f90 +++ b/src/appl/rcsfgenerate90/gen_I.f90 @@ -1,16 +1,16 @@ - MODULE gen_I + MODULE gen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE gen (ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(110), INTENT(IN) :: POSN - integer, DIMENSION(110), INTENT(IN) :: POSL - integer, INTENT(IN) :: SKAL - integer, INTENT(INOUT) :: CF - logical, INTENT(IN) :: FIRST - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ - integer :: PAR - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE gen (ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(110), INTENT(IN) :: POSN + integer, DIMENSION(110), INTENT(IN) :: POSL + integer, INTENT(IN) :: SKAL + integer, INTENT(INOUT) :: CF + logical, INTENT(IN) :: FIRST + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ + integer :: PAR + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/genb.f90 b/src/appl/rcsfgenerate90/genb.f90 index a255ab94d..d64cbd940 100644 --- a/src/appl/rcsfgenerate90/genb.f90 +++ b/src/appl/rcsfgenerate90/genb.f90 @@ -1,891 +1,891 @@ ! last edited July 31, 1996 - SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + SUBROUTINE GEN(ANSATS, POSN, POSL, SKAL, CF, FIRST, MINJ, MAXJ, PAR) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE kopp1_I - USE kopp2_I + USE kopp1_I + USE kopp2_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: SKAL - INTEGER , INTENT(INOUT) :: CF - INTEGER , INTENT(IN) :: MINJ - INTEGER , INTENT(IN) :: MAXJ - INTEGER :: PAR - LOGICAL , INTENT(IN) :: FIRST - INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) - INTEGER , INTENT(IN) :: POSN(110) - INTEGER , INTENT(IN) :: POSL(110) + INTEGER , INTENT(IN) :: SKAL + INTEGER , INTENT(INOUT) :: CF + INTEGER , INTENT(IN) :: MINJ + INTEGER , INTENT(IN) :: MAXJ + INTEGER :: PAR + LOGICAL , INTENT(IN) :: FIRST + INTEGER , INTENT(IN) :: ANSATS(15,0:10,0:1) + INTEGER , INTENT(IN) :: POSN(110) + INTEGER , INTENT(IN) :: POSL(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: FIL_1 = 7 - INTEGER, PARAMETER :: FIL_2 = 8 + INTEGER, PARAMETER :: FIL_1 = 7 + INTEGER, PARAMETER :: FIL_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT - INTEGER , DIMENSION(0:10,0:1) :: ANTMAX - INTEGER :: POS, I, N, L, K - INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL + INTEGER , DIMENSION(0:10,0:11,0:1) :: KOPPL + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: JKVANT + INTEGER , DIMENSION(0:10,0:1) :: ANTMAX + INTEGER :: POS, I, N, L, K + INTEGER , DIMENSION(20) :: J, JK, ORBIT, ANTEL INTEGER :: I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, I11, I12, I13, I14, & - I15, I16, I17, I18, I19, I20 - INTEGER , DIMENSION(20) :: PLUS, S + I15, I16, I17, I18, I19, I20 + INTEGER , DIMENSION(20) :: PLUS, S INTEGER :: RESJ, JK1, JK2, JK3, JK4, JK5, JK6, JK7, JK8, JK9, JK10, JK11& - , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL - INTEGER , DIMENSION(20) :: ANTKO - INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR - INTEGER :: N1, N10 - CHARACTER :: RAD1*200, RAD2*200, RAD3*200 - CHARACTER, DIMENSION(0:10,0:1) :: L1*2 + , JK12, JK13, JK14, JK15, JK16, JK17, JK18, FIL + INTEGER , DIMENSION(20) :: ANTKO + INTEGER , DIMENSION(0:10,0:1,0:5,20) :: SENIOR + INTEGER :: N1, N10 + CHARACTER :: RAD1*200, RAD2*200, RAD3*200 + CHARACTER, DIMENSION(0:10,0:1) :: L1*2 !----------------------------------------------- DATA (L1(I,0),I=0,10)/ 's ', 'p-', 'd-', 'f-', 'g-', 'h-', 'i-', 'k-', & - 'l-', 'm-', 'n-'/ + 'l-', 'm-', 'n-'/ DATA (L1(I,1),I=0,10)/ 's ', 'p ', 'd ', 'f ', 'g ', 'h ', 'i ', 'k ', & - 'l ', 'm ', 'n '/ + 'l ', 'm ', 'n '/ ! The value of antmax(l-number,x) is the maximum number of electrons ! in the orbital, x represents +/- coupling of s- and l- number - DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ - DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ + DATA (ANTMAX(I,0),I=0,10)/ 2, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20/ + DATA (ANTMAX(I,1),I=0,10)/ 0, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22/ ! The value of koppl(l-number,number of electrons,x) is the number of ! possible couplings for a certain orbital. If the orbital is ! populated with more than half of the maximal number of electrons ! the index "number of electrons" should be substituted with ! "antmax(l-number) - number of electrons". - DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(0,I,0),I=0,1)/ 1, 1/ ! l=0 - DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ - DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(1,I,0),I=0,1)/ 1, 1/ + DATA (KOPPL(1,I,1),I=0,2)/ 1, 1, 2/ ! l=1 - DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ - DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(2,I,0),I=0,2)/ 1, 1, 2/ + DATA (KOPPL(2,I,1),I=0,3)/ 1, 1, 3, 3/ ! l=2 - DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ - DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(3,I,0),I=0,3)/ 1, 1, 3, 3/ + DATA (KOPPL(3,I,1),I=0,4)/ 1, 1, 4, 6, 8/ ! l=3 - DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ - DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(4,I,0),I=0,4)/ 1, 1, 4, 6, 8/ + DATA (KOPPL(4,I,1),I=0,5)/ 1, 1, 5, 10, 16, 20/ ! l=4 - DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ - DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(5,I,0),I=0,5)/ 1, 1, 5, 10, 16, 20/ + DATA (KOPPL(5,I,1),I=0,2)/ 1, 1, 6/ ! l=5 - DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ - DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(6,I,0),I=0,2)/ 1, 1, 6/ + DATA (KOPPL(6,I,1),I=0,2)/ 1, 1, 7/ ! l=6 - DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ - DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(7,I,0),I=0,2)/ 1, 1, 7/ + DATA (KOPPL(7,I,1),I=0,2)/ 1, 1, 8/ ! l=7 - DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ - DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(8,I,0),I=0,2)/ 1, 1, 8/ + DATA (KOPPL(8,I,1),I=0,2)/ 1, 1, 9/ ! l=8 - DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ - DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(9,I,0),I=0,2)/ 1, 1, 9/ + DATA (KOPPL(9,I,1),I=0,2)/ 1, 1, 10/ ! l=9 - DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ - DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ + DATA (KOPPL(10,I,0),I=0,2)/ 1, 1, 10/ + DATA (KOPPL(10,I,1),I=0,2)/ 1, 1, 11/ ! l=10 - + ! JKVANT(l-number, +/-, number of electrons, coupling number) is 2*J-number - - DATA JKVANT(0,0,0,1)/ 0/ + + DATA JKVANT(0,0,0,1)/ 0/ ! data SENIOR(0,0,0,1) / 0/ - DATA SENIOR(0,0,0,1)/ -1/ + DATA SENIOR(0,0,0,1)/ -1/ ! l=0 #=0 - DATA JKVANT(0,0,1,1)/ 1/ + DATA JKVANT(0,0,1,1)/ 1/ ! data SENIOR(0,0,1,1) / 1/ - DATA SENIOR(0,0,1,1)/ -1/ + DATA SENIOR(0,0,1,1)/ -1/ ! l=0 #=1 - DATA JKVANT(1,0,0,1)/ 0/ + DATA JKVANT(1,0,0,1)/ 0/ ! data SENIOR(1,0,0,1) / 0/ - DATA SENIOR(1,0,0,1)/ -1/ + DATA SENIOR(1,0,0,1)/ -1/ ! l=1 #=0 - - DATA JKVANT(1,0,1,1)/ 1/ + DATA JKVANT(1,0,1,1)/ 1/ ! data SENIOR(1,0,1,1) / 1/ - DATA SENIOR(1,0,1,1)/ -1/ + DATA SENIOR(1,0,1,1)/ -1/ ! l=1 #=1 - - DATA JKVANT(1,1,0,1)/ 0/ + DATA JKVANT(1,1,0,1)/ 0/ ! data SENIOR(1,1,0,1) / 0/ - DATA SENIOR(1,1,0,1)/ -1/ + DATA SENIOR(1,1,0,1)/ -1/ ! l=1 #=0 + - DATA JKVANT(1,1,1,1)/ 3/ + DATA JKVANT(1,1,1,1)/ 3/ ! data SENIOR(1,1,1,1) / 1/ - DATA SENIOR(1,1,1,1)/ -1/ + DATA SENIOR(1,1,1,1)/ -1/ ! l=1 #=1 + - DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(1,1,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(1,1,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(1,1,2,I),I=1,2)/ -1, -1/ ! l=1 #=2 + - DATA JKVANT(2,0,0,1)/ 0/ + DATA JKVANT(2,0,0,1)/ 0/ ! data SENIOR(2,0,0,1) / 0/ - DATA SENIOR(2,0,0,1)/ -1/ + DATA SENIOR(2,0,0,1)/ -1/ ! l=2 #=0 - - DATA JKVANT(2,0,1,1)/ 3/ + DATA JKVANT(2,0,1,1)/ 3/ ! data SENIOR(2,0,1,1) / 1/ - DATA SENIOR(2,0,1,1)/ -1/ + DATA SENIOR(2,0,1,1)/ -1/ ! l=2 #=1 - - DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ + DATA (JKVANT(2,0,2,I),I=1,2)/ 0, 4/ ! data (SENIOR(2,0,2,i),i=1,2) / 0, 2/ - DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ + DATA (SENIOR(2,0,2,I),I=1,2)/ -1, -1/ ! l=2 #=2 - - DATA JKVANT(2,1,0,1)/ 0/ + DATA JKVANT(2,1,0,1)/ 0/ ! data SENIOR(2,1,0,1) / 0/ - DATA SENIOR(2,1,0,1)/ -1/ + DATA SENIOR(2,1,0,1)/ -1/ ! l=2 #=0 + - DATA JKVANT(2,1,1,1)/ 5/ + DATA JKVANT(2,1,1,1)/ 5/ ! data SENIOR(2,1,1,1) / 1/ - DATA SENIOR(2,1,1,1)/ -1/ + DATA SENIOR(2,1,1,1)/ -1/ ! l=2 #=1 + - DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(2,1,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(2,1,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,2,I),I=1,3)/ -1, -1, -1/ ! l=2 #=2 + - DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(2,1,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(2,1,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(2,1,3,I),I=1,3)/ -1, -1, -1/ ! l=2 #=3 + - DATA JKVANT(3,0,0,1)/ 0/ + DATA JKVANT(3,0,0,1)/ 0/ ! data SENIOR(3,0,0,1) / 0/ - DATA SENIOR(3,0,0,1)/ -1/ + DATA SENIOR(3,0,0,1)/ -1/ ! l=3 #=0 - - DATA JKVANT(3,0,1,1)/ 5/ + DATA JKVANT(3,0,1,1)/ 5/ ! data SENIOR(3,0,1,1) / 1/ - DATA SENIOR(3,0,1,1)/ -1/ + DATA SENIOR(3,0,1,1)/ -1/ ! l=3 #=1 - - DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ + DATA (JKVANT(3,0,2,I),I=1,3)/ 0, 4, 8/ ! data (SENIOR(3,0,2,i),i=1,3) / 0, 2, 2/ - DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,2,I),I=1,3)/ -1, -1, -1/ ! l=3 #=2 - - DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ + DATA (JKVANT(3,0,3,I),I=1,3)/ 5, 3, 9/ ! data (SENIOR(3,0,3,i),i=1,3) / 1, 3, 3/ - DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ + DATA (SENIOR(3,0,3,I),I=1,3)/ -1, -1, -1/ ! l=3 #=3 - - DATA JKVANT(3,1,0,1)/ 0/ + DATA JKVANT(3,1,0,1)/ 0/ ! data SENIOR(3,1,0,1) / 0/ - DATA SENIOR(3,1,0,1)/ -1/ + DATA SENIOR(3,1,0,1)/ -1/ ! l=3 #=0 + - DATA JKVANT(3,1,1,1)/ 7/ + DATA JKVANT(3,1,1,1)/ 7/ ! data SENIOR(3,1,1,1) / 1/ - DATA SENIOR(3,1,1,1)/ -1/ + DATA SENIOR(3,1,1,1)/ -1/ ! l=3 #=1 + - DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(3,1,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(3,1,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(3,1,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=3 #=2 + - DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(3,1,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(3,1,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(3,1,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=3 #=3 + - DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(3,1,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(3,1,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(3,1,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=3 #=4 + - DATA JKVANT(4,0,0,1)/ 0/ + DATA JKVANT(4,0,0,1)/ 0/ ! data SENIOR(4,0,0,1) / 0/ - DATA SENIOR(4,0,0,1)/ -1/ + DATA SENIOR(4,0,0,1)/ -1/ ! l=4 #=0 - - DATA JKVANT(4,0,1,1)/ 7/ + DATA JKVANT(4,0,1,1)/ 7/ ! data SENIOR(4,0,1,1) / 1/ - DATA SENIOR(4,0,1,1)/ -1/ + DATA SENIOR(4,0,1,1)/ -1/ ! l=4 #=1 - - DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ + DATA (JKVANT(4,0,2,I),I=1,4)/ 0, 4, 8, 12/ ! data (SENIOR(4,0,2,i),i=1,4) / 0, 2, 2, 2/ - DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ + DATA (SENIOR(4,0,2,I),I=1,4)/ -1, -1, -1, -1/ ! l=4 #=2 - - DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ + DATA (JKVANT(4,0,3,I),I=1,6)/ 7, 3, 5, 9, 11, 15/ ! data (SENIOR(4,0,3,i),i=1,6) / 1, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,0,3,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=4 #=3 - - DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ + DATA (JKVANT(4,0,4,I),I=1,8)/ 0, 4, 8, 12, 4, 8, 10, 16/ ! data (SENIOR(4,0,4,i),i=1,8) / 0, 2, 2, 2, 4, 4, 4, 4/ - DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ + DATA (SENIOR(4,0,4,I),I=1,8)/ -1, 2, 2, -1, 4, 4, -1, -1/ ! l=4 #=4 - - DATA JKVANT(4,1,0,1)/ 0/ + DATA JKVANT(4,1,0,1)/ 0/ ! data SENIOR(4,1,0,1) / 0/ - DATA SENIOR(4,1,0,1)/ -1/ + DATA SENIOR(4,1,0,1)/ -1/ ! l=4 #=0 + - DATA JKVANT(4,1,1,1)/ 9/ + DATA JKVANT(4,1,1,1)/ 9/ ! data SENIOR(4,1,1,1) / 1/ - DATA SENIOR(4,1,1,1)/ -1/ + DATA SENIOR(4,1,1,1)/ -1/ ! l=4 #=1 + - DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(4,1,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(4,1,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=4 #=2 + - DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(4,1,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(4,1,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(4,1,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=4 #=3 + DATA (JKVANT(4,1,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(4,1,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(4,1,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=4 #=4 + DATA (JKVANT(4,1,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(4,1,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(4,1,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=4 #=5 + - DATA JKVANT(5,0,0,1)/ 0/ + DATA JKVANT(5,0,0,1)/ 0/ ! data SENIOR(5,0,0,1) / 0/ - DATA SENIOR(5,0,0,1)/ -1/ + DATA SENIOR(5,0,0,1)/ -1/ ! l=5 #=0 - - DATA JKVANT(5,0,1,1)/ 9/ + DATA JKVANT(5,0,1,1)/ 9/ ! data SENIOR(5,0,1,1) / 1/ - DATA SENIOR(5,0,1,1)/ -1/ + DATA SENIOR(5,0,1,1)/ -1/ ! l=5 #=1 - - DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ + DATA (JKVANT(5,0,2,I),I=1,5)/ 0, 4, 8, 12, 16/ ! data (SENIOR(5,0,2,i),i=1,5) / 0, 2, 2, 2, 2/ - DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,2,I),I=1,5)/ -1, -1, -1, -1, -1/ ! l=5 #=2 - - DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ + DATA (JKVANT(5,0,3,I),I=1,10)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21/ ! data (SENIOR(5,0,3,i),i=1,10) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3/ - DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,0,3,I),I=1,10)/ 1, -1, -1, -1, 3, -1, -1, -1, -1, -1/ ! l=5 #=3 - DATA (JKVANT(5,0,4,I),I=1,16)/ 0, 4, 8, 12, 16, 0, 4, 6, 8, 10, 12, 14, & - 16, 18, 20, 24/ + 16, 18, 20, 24/ ! data (SENIOR(5,0,4,i),i=1,16) / 0, 2, 2, 2, 2, 4, 4, 4, 4, 4, 4, ! : 4, 4, 4, 4, 4/ DATA (SENIOR(5,0,4,I),I=1,16)/ 0, 2, 2, 2, 2, 4, 4, -1, 4, -1, 4, -1, 4, & - -1, -1, -1/ + -1, -1, -1/ ! l=5 #=4 - DATA (JKVANT(5,0,5,I),I=1,20)/ 9, 3, 5, 7, 9, 11, 13, 15, 17, 21, 1, 5, 7& - , 9, 11, 13, 15, 17, 19, 25/ + , 9, 11, 13, 15, 17, 19, 25/ ! data (SENIOR(5,0,5,i),i=1,20) / 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, ! : 5, 5, 5, 5, 5, 5, 5, 5, 5/ DATA (SENIOR(5,0,5,I),I=1,20)/ 1, -1, 3, 3, 3, 3, 3, 3, 3, -1, -1, 5, 5, & - 5, 5, 5, 5, 5, -1, -1/ + 5, 5, 5, 5, 5, -1, -1/ ! l=5 #=5 - - DATA JKVANT(5,1,0,1)/ 0/ + DATA JKVANT(5,1,0,1)/ 0/ ! data SENIOR(5,1,0,1) / 0/ - DATA SENIOR(5,1,0,1)/ -1/ + DATA SENIOR(5,1,0,1)/ -1/ ! l=5 #=0 + - DATA JKVANT(5,1,1,1)/ 11/ + DATA JKVANT(5,1,1,1)/ 11/ ! data SENIOR(5,1,1,1) / 1/ - DATA SENIOR(5,1,1,1)/ -1/ + DATA SENIOR(5,1,1,1)/ -1/ ! l=5 #=1 + - DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (JKVANT(5,1,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ ! data (SENIOR(5,1,2,i),i=1,6) / 0, 2, 2, 2, 2, 2/ - DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(5,1,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=5 #=2 + - DATA JKVANT(6,0,0,1)/ 0/ + DATA JKVANT(6,0,0,1)/ 0/ ! data SENIOR(6,0,0,1) / 0/ - DATA SENIOR(6,0,0,1)/ -1/ + DATA SENIOR(6,0,0,1)/ -1/ ! l=6 #=0 - - DATA JKVANT(6,0,1,1)/ 11/ + DATA JKVANT(6,0,1,1)/ 11/ ! data SENIOR(6,0,1,1) / 1/ - DATA SENIOR(6,0,1,1)/ -1/ + DATA SENIOR(6,0,1,1)/ -1/ ! l=6 #=1 - - DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ + DATA (JKVANT(6,0,2,I),I=1,6)/ 0, 4, 8, 12, 16, 20/ ! data (SENIOR(6,0,2,i),i=1,6) / 0, 2, 2, 2, 2, 2/ - DATA (SENIOR(6,0,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(6,0,2,I),I=1,6)/ -1, -1, -1, -1, -1, -1/ ! l=6 #=2 - - DATA JKVANT(6,1,0,1)/ 0/ + DATA JKVANT(6,1,0,1)/ 0/ ! data SENIOR(6,1,0,1) / 0/ - DATA SENIOR(6,1,0,1)/ -1/ + DATA SENIOR(6,1,0,1)/ -1/ ! l=6 #=0 + - DATA JKVANT(6,1,1,1)/ 13/ + DATA JKVANT(6,1,1,1)/ 13/ ! data SENIOR(6,1,1,1) / 1/ - DATA SENIOR(6,1,1,1)/ -1/ + DATA SENIOR(6,1,1,1)/ -1/ ! l=6 #=1 + - DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (JKVANT(6,1,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ ! data (SENIOR(6,1,2,i),i=1,7) / 0, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(6,1,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(6,1,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ ! l=6 #=2 + - DATA JKVANT(7,0,0,1)/ 0/ + DATA JKVANT(7,0,0,1)/ 0/ ! data SENIOR(7,0,0,1) / 0/ - DATA SENIOR(7,0,0,1)/ -1/ + DATA SENIOR(7,0,0,1)/ -1/ ! l=7 #=0 - - DATA JKVANT(7,0,1,1)/ 13/ + DATA JKVANT(7,0,1,1)/ 13/ ! data SENIOR(7,0,1,1) / 1/ - DATA SENIOR(7,0,1,1)/ -1/ + DATA SENIOR(7,0,1,1)/ -1/ ! l=7 #=1 - - DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ + DATA (JKVANT(7,0,2,I),I=1,7)/ 0, 4, 8, 12, 16, 20, 24/ ! data (SENIOR(7,0,2,i),i=1,7) / 0, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(7,0,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(7,0,2,I),I=1,7)/ -1, -1, -1, -1, -1, -1, -1/ ! l=7 #=2 - - DATA JKVANT(7,1,0,1)/ 0/ + DATA JKVANT(7,1,0,1)/ 0/ ! data SENIOR(7,1,0,1) / 0/ - DATA SENIOR(7,1,0,1)/ -1/ + DATA SENIOR(7,1,0,1)/ -1/ ! l=7 #=0 + - DATA JKVANT(7,1,1,1)/ 15/ + DATA JKVANT(7,1,1,1)/ 15/ ! data SENIOR(7,1,1,1) / 1/ - DATA SENIOR(7,1,1,1)/ -1/ + DATA SENIOR(7,1,1,1)/ -1/ ! l=7 #=1 + - DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (JKVANT(7,1,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ ! data (SENIOR(7,1,2,i),i=1,8) / 0, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(7,1,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(7,1,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ ! l=7 #=2 + - DATA JKVANT(8,0,0,1)/ 0/ + DATA JKVANT(8,0,0,1)/ 0/ ! data SENIOR(8,0,0,1) / 0/ - DATA SENIOR(8,0,0,1)/ -1/ + DATA SENIOR(8,0,0,1)/ -1/ ! l=8 #=0 - - DATA JKVANT(8,0,1,1)/ 15/ + DATA JKVANT(8,0,1,1)/ 15/ ! data SENIOR(8,0,1,1) / 1/ - DATA SENIOR(8,0,1,1)/ -1/ + DATA SENIOR(8,0,1,1)/ -1/ ! l=8 #=1 - - DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ + DATA (JKVANT(8,0,2,I),I=1,8)/ 0, 4, 8, 12, 16, 20, 24, 28/ ! data (SENIOR(8,0,2,i),i=1,8) / 0, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(8,0,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(8,0,2,I),I=1,8)/ -1, -1, -1, -1, -1, -1, -1, -1/ ! l=8 #=2 - - DATA JKVANT(8,1,0,1)/ 0/ + DATA JKVANT(8,1,0,1)/ 0/ ! data SENIOR(8,1,0,1) / 0/ - DATA SENIOR(8,1,0,1)/ -1/ + DATA SENIOR(8,1,0,1)/ -1/ ! l=8 #=0 + - DATA JKVANT(8,1,1,1)/ 17/ + DATA JKVANT(8,1,1,1)/ 17/ ! data SENIOR(8,1,1,1) / 1/ - DATA SENIOR(8,1,1,1)/ -1/ + DATA SENIOR(8,1,1,1)/ -1/ ! l=8 #=1 + - DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (JKVANT(8,1,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ ! data (SENIOR(8,1,2,i),i=1,9) / 0, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(8,1,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(8,1,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=8 #=2 + - DATA JKVANT(9,0,0,1)/ 0/ + DATA JKVANT(9,0,0,1)/ 0/ ! data SENIOR(9,0,0,1) / 0/ - DATA SENIOR(9,0,0,1)/ -1/ + DATA SENIOR(9,0,0,1)/ -1/ ! l=9 #=0 - - DATA JKVANT(9,0,1,1)/ 17/ + DATA JKVANT(9,0,1,1)/ 17/ ! data SENIOR(9,0,1,1) / 1/ - DATA SENIOR(9,0,1,1)/ -1/ + DATA SENIOR(9,0,1,1)/ -1/ ! l=9 #=1 - - DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ + DATA (JKVANT(9,0,2,I),I=1,9)/ 0, 4, 8, 12, 16, 20, 24, 28, 32/ ! data (SENIOR(9,0,2,i),i=1,9) / 0, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(9,0,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(9,0,2,I),I=1,9)/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=9 #=2 - - DATA JKVANT(9,1,0,1)/ 0/ + DATA JKVANT(9,1,0,1)/ 0/ ! data SENIOR(9,1,0,1) / 0/ - DATA SENIOR(9,1,0,1)/ -1/ + DATA SENIOR(9,1,0,1)/ -1/ ! l=9 #=0 + - DATA JKVANT(9,1,1,1)/ 19/ + DATA JKVANT(9,1,1,1)/ 19/ ! data SENIOR(9,1,1,1) / 1/ - DATA SENIOR(9,1,1,1)/ -1/ + DATA SENIOR(9,1,1,1)/ -1/ ! l=9 #=1 + - DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (JKVANT(9,1,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ ! data (SENIOR(9,1,2,i),i=1,10) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(9,1,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(9,1,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=9 #=2 + - DATA JKVANT(10,0,0,1)/ 0/ + DATA JKVANT(10,0,0,1)/ 0/ ! data SENIOR(10,0,0,1) / 0/ - DATA SENIOR(10,0,0,1)/ -1/ + DATA SENIOR(10,0,0,1)/ -1/ ! l=10 #=0 - - DATA JKVANT(10,0,1,1)/ 19/ + DATA JKVANT(10,0,1,1)/ 19/ ! data SENIOR(10,0,1,1) / 1/ - DATA SENIOR(10,0,1,1)/ -1/ + DATA SENIOR(10,0,1,1)/ -1/ ! l=10 #=1 - - DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ + DATA (JKVANT(10,0,2,I),I=1,10)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36/ ! data (SENIOR(10,0,2,i),i=1,10) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2/ - DATA (SENIOR(10,0,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ + DATA (SENIOR(10,0,2,I),I=1,10)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1/ ! l=10 #=2 - - DATA JKVANT(10,1,0,1)/ 0/ + DATA JKVANT(10,1,0,1)/ 0/ ! data SENIOR(10,1,0,1) / 0/ - DATA SENIOR(10,1,0,1)/ -1/ + DATA SENIOR(10,1,0,1)/ -1/ ! l=10 #=0 + - DATA JKVANT(10,1,1,1)/ 21/ + DATA JKVANT(10,1,1,1)/ 21/ ! data SENIOR(10,1,1,1) / 1/ - DATA SENIOR(10,1,1,1)/ -1/ + DATA SENIOR(10,1,1,1)/ -1/ ! l=10 #=1 + - DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ + DATA (JKVANT(10,1,2,I),I=1,11)/ 0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40/ ! data (SENIOR(10,1,2,i),i=1,11) / 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, ! : 2/ DATA (SENIOR(10,1,2,I),I=1,11)/ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, & - -1/ + -1/ ! l=10 #=2 + - IF (FIRST) THEN - FIL = FIL_1 - ELSE - FIL = FIL_2 - ENDIF - ANTKO = 1 - POS = 0 - DO I = 1, 110 - N = POSN(I) - L = POSL(I) + IF (FIRST) THEN + FIL = FIL_1 + ELSE + FIL = FIL_2 + ENDIF + ANTKO = 1 + POS = 0 + DO I = 1, 110 + N = POSN(I) + L = POSL(I) !Jacek mailed the fix 98-10-29 - IF (N < 10) THEN - DO K = 0, MIN(L,1) + IF (N < 10) THEN + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ELSE - DO K = 0, MIN(L,1) + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ELSE + DO K = 0, MIN(L,1) !do 20 k=0,min(n-1,1) - IF (ANSATS(N,L,K) == 0) CYCLE - RAD1(POS*9+1:POS*9+9) = ' ' - N1 = MOD(N,10) - N10 = N/10 - RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) - RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) - RAD1(POS*9+4:POS*9+5) = L1(L,K) - RAD1(POS*9+6:POS*9+9) = '( )' - IF (ANSATS(N,L,K) >= 10) THEN - RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) - ELSE - RAD1(POS*9+7:POS*9+7) = ' ' - ENDIF - RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) - POS = POS + 1 - IF (POS > SKAL) THEN - WRITE (*, *) 'More than 20 subshells' - RETURN - ENDIF - ORBIT(POS) = L - ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) - ANTKO(POS) = KOPPL(L,ANTEL(POS),K) - PLUS(POS) = K - END DO - ENDIF - END DO - - IF (POS == 0) RETURN - DO I1 = 1, ANTKO(1) - DO I2 = 1, ANTKO(2) - DO I3 = 1, ANTKO(3) - DO I4 = 1, ANTKO(4) - DO I5 = 1, ANTKO(5) - DO I6 = 1, ANTKO(6) - DO I7 = 1, ANTKO(7) - DO I8 = 1, ANTKO(8) - DO I9 = 1, ANTKO(9) - DO I10 = 1, ANTKO(10) - DO I11 = 1, ANTKO(11) - DO I12 = 1, ANTKO(12) - DO I13 = 1, ANTKO(13) - DO I14 = 1, ANTKO(14) - DO I15 = 1, ANTKO(15) - DO I16 = 1, ANTKO(16) - DO I17 = 1, ANTKO(17) - DO I18 = 1, ANTKO(18) - DO I19 = 1, ANTKO(19) - DO I20 = 1, ANTKO(20) - - J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) - S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) - IF (POS == 1) THEN - IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:9) - WRITE (FIL, 999) RAD2(1:9) - WRITE (FIL, 999) RAD3(1:11) - CF = CF + 1 - ENDIF - ELSE - - DO RESJ = MINJ, MAXJ, 2 - JK(POS-1) = RESJ - J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) - S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) - IF (POS == 2) THEN + IF (ANSATS(N,L,K) == 0) CYCLE + RAD1(POS*9+1:POS*9+9) = ' ' + N1 = MOD(N,10) + N10 = N/10 + RAD1(POS*9+2:POS*9+2) = CHAR(48 + N10) + RAD1(POS*9+3:POS*9+3) = CHAR(48 + N1) + RAD1(POS*9+4:POS*9+5) = L1(L,K) + RAD1(POS*9+6:POS*9+9) = '( )' + IF (ANSATS(N,L,K) >= 10) THEN + RAD1(POS*9+7:POS*9+8) = CHAR(ANSATS(N,L,K)/10+48) + ELSE + RAD1(POS*9+7:POS*9+7) = ' ' + ENDIF + RAD1(POS*9+8:POS*9+8) = CHAR(MOD(ANSATS(N,L,K),10)+48) + POS = POS + 1 + IF (POS > SKAL) THEN + WRITE (*, *) 'More than 20 subshells' + RETURN + ENDIF + ORBIT(POS) = L + ANTEL(POS) = MIN(ANSATS(N,L,K),ANTMAX(L,K)-ANSATS(N,L,K)) + ANTKO(POS) = KOPPL(L,ANTEL(POS),K) + PLUS(POS) = K + END DO + ENDIF + END DO + + IF (POS == 0) RETURN + DO I1 = 1, ANTKO(1) + DO I2 = 1, ANTKO(2) + DO I3 = 1, ANTKO(3) + DO I4 = 1, ANTKO(4) + DO I5 = 1, ANTKO(5) + DO I6 = 1, ANTKO(6) + DO I7 = 1, ANTKO(7) + DO I8 = 1, ANTKO(8) + DO I9 = 1, ANTKO(9) + DO I10 = 1, ANTKO(10) + DO I11 = 1, ANTKO(11) + DO I12 = 1, ANTKO(12) + DO I13 = 1, ANTKO(13) + DO I14 = 1, ANTKO(14) + DO I15 = 1, ANTKO(15) + DO I16 = 1, ANTKO(16) + DO I17 = 1, ANTKO(17) + DO I18 = 1, ANTKO(18) + DO I19 = 1, ANTKO(19) + DO I20 = 1, ANTKO(20) + + J(1) = JKVANT(ORBIT(1),PLUS(1),ANTEL(1),I1) + S(1) = SENIOR(ORBIT(1),PLUS(1),ANTEL(1),I1) + IF (POS == 1) THEN + IF (J(1)>=MINJ .AND. J(1)<=MAXJ) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, J, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:9) + WRITE (FIL, 999) RAD2(1:9) + WRITE (FIL, 999) RAD3(1:11) + CF = CF + 1 + ENDIF + ELSE + + DO RESJ = MINJ, MAXJ, 2 + JK(POS-1) = RESJ + J(2) = JKVANT(ORBIT(2),PLUS(2),ANTEL(2),I2) + S(2) = SENIOR(ORBIT(2),PLUS(2),ANTEL(2),I2) + IF (POS == 2) THEN IF (RESJ>=ABS(J(1)-J(2)) .AND. RESJ<=J(1)+J& - (2)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:18) - WRITE (FIL, 999) RAD2(1:18) - WRITE (FIL, 999) RAD3(1:20) - CF = CF + 1 - ENDIF - ELSE - - J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) - S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) - DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 - JK(1) = JK1 - IF (POS == 3) THEN + (2)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:18) + WRITE (FIL, 999) RAD2(1:18) + WRITE (FIL, 999) RAD3(1:20) + CF = CF + 1 + ENDIF + ELSE + + J(3) = JKVANT(ORBIT(3),PLUS(3),ANTEL(3),I3) + S(3) = SENIOR(ORBIT(3),PLUS(3),ANTEL(3),I3) + DO JK1 = ABS(J(1)-J(2)), J(1) + J(2), 2 + JK(1) = JK1 + IF (POS == 3) THEN IF (RESJ>=ABS(JK1 - J(3)) .AND. RESJ<=JK1+J& - (3)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:27) - WRITE (FIL, 999) RAD2(1:27) - WRITE (FIL, 999) RAD3(1:29) - CF = CF + 1 - ENDIF - ELSE - - J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) - S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) - DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 - JK(2) = JK2 - IF (POS == 4) THEN + (3)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:27) + WRITE (FIL, 999) RAD2(1:27) + WRITE (FIL, 999) RAD3(1:29) + CF = CF + 1 + ENDIF + ELSE + + J(4) = JKVANT(ORBIT(4),PLUS(4),ANTEL(4),I4) + S(4) = SENIOR(ORBIT(4),PLUS(4),ANTEL(4),I4) + DO JK2 = ABS(JK1 - J(3)), JK1 + J(3), 2 + JK(2) = JK2 + IF (POS == 4) THEN IF (RESJ>=ABS(JK2 - J(4)) .AND. RESJ<=JK2+J& - (4)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:36) - WRITE (FIL, 999) RAD2(1:36) - WRITE (FIL, 999) RAD3(1:38) - CF = CF + 1 - ENDIF - ELSE - - J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) - S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) - DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 - JK(3) = JK3 - IF (POS == 5) THEN + (4)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:36) + WRITE (FIL, 999) RAD2(1:36) + WRITE (FIL, 999) RAD3(1:38) + CF = CF + 1 + ENDIF + ELSE + + J(5) = JKVANT(ORBIT(5),PLUS(5),ANTEL(5),I5) + S(5) = SENIOR(ORBIT(5),PLUS(5),ANTEL(5),I5) + DO JK3 = ABS(JK2 - J(4)), JK2 + J(4), 2 + JK(3) = JK3 + IF (POS == 5) THEN IF (RESJ>=ABS(JK3 - J(5)) .AND. RESJ<=JK3+J& - (5)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:45) - WRITE (FIL, 999) RAD2(1:45) - WRITE (FIL, 999) RAD3(1:47) - CF = CF + 1 - ENDIF - ELSE - - J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) - S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) - DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 - JK(4) = JK4 - IF (POS == 6) THEN + (5)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:45) + WRITE (FIL, 999) RAD2(1:45) + WRITE (FIL, 999) RAD3(1:47) + CF = CF + 1 + ENDIF + ELSE + + J(6) = JKVANT(ORBIT(6),PLUS(6),ANTEL(6),I6) + S(6) = SENIOR(ORBIT(6),PLUS(6),ANTEL(6),I6) + DO JK4 = ABS(JK3 - J(5)), JK3 + J(5), 2 + JK(4) = JK4 + IF (POS == 6) THEN IF (RESJ>=ABS(JK4 - J(6)) .AND. RESJ<=JK4+J& - (6)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:54) - WRITE (FIL, 999) RAD2(1:54) - WRITE (FIL, 999) RAD3(1:56) - CF = CF + 1 - ENDIF - ELSE - - J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) - S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) - DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 - JK(5) = JK5 - IF (POS == 7) THEN + (6)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:54) + WRITE (FIL, 999) RAD2(1:54) + WRITE (FIL, 999) RAD3(1:56) + CF = CF + 1 + ENDIF + ELSE + + J(7) = JKVANT(ORBIT(7),PLUS(7),ANTEL(7),I7) + S(7) = SENIOR(ORBIT(7),PLUS(7),ANTEL(7),I7) + DO JK5 = ABS(JK4 - J(6)), JK4 + J(6), 2 + JK(5) = JK5 + IF (POS == 7) THEN IF (RESJ>=ABS(JK5 - J(7)) .AND. RESJ<=JK5+J& - (7)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:63) - WRITE (FIL, 999) RAD2(1:63) - WRITE (FIL, 999) RAD3(1:65) - CF = CF + 1 - ENDIF - ELSE - - J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) - S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) - DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 - JK(6) = JK6 - IF (POS == 8) THEN + (7)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:63) + WRITE (FIL, 999) RAD2(1:63) + WRITE (FIL, 999) RAD3(1:65) + CF = CF + 1 + ENDIF + ELSE + + J(8) = JKVANT(ORBIT(8),PLUS(8),ANTEL(8),I8) + S(8) = SENIOR(ORBIT(8),PLUS(8),ANTEL(8),I8) + DO JK6 = ABS(JK5 - J(7)), JK5 + J(7), 2 + JK(6) = JK6 + IF (POS == 8) THEN IF (RESJ>=ABS(JK6 - J(8)) .AND. RESJ<=JK6+J& - (8)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:72) - WRITE (FIL, 999) RAD2(1:72) - WRITE (FIL, 999) RAD3(1:74) - CF = CF + 1 - ENDIF - ELSE - - J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) - S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) - DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 - JK(7) = JK7 - IF (POS == 9) THEN + (8)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:72) + WRITE (FIL, 999) RAD2(1:72) + WRITE (FIL, 999) RAD3(1:74) + CF = CF + 1 + ENDIF + ELSE + + J(9) = JKVANT(ORBIT(9),PLUS(9),ANTEL(9),I9) + S(9) = SENIOR(ORBIT(9),PLUS(9),ANTEL(9),I9) + DO JK7 = ABS(JK6 - J(8)), JK6 + J(8), 2 + JK(7) = JK7 + IF (POS == 9) THEN IF (RESJ>=ABS(JK7 - J(9)) .AND. RESJ<=JK7+J& - (9)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:81) - WRITE (FIL, 999) RAD2(1:81) - WRITE (FIL, 999) RAD3(1:83) - CF = CF + 1 - ENDIF - ELSE - + (9)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:81) + WRITE (FIL, 999) RAD2(1:81) + WRITE (FIL, 999) RAD3(1:83) + CF = CF + 1 + ENDIF + ELSE + J(10) = JKVANT(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) + ,I10) S(10) = SENIOR(ORBIT(10),PLUS(10),ANTEL(10)& - ,I10) - DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 - JK(8) = JK8 - IF (POS == 10) THEN + ,I10) + DO JK8 = ABS(JK7 - J(9)), JK7 + J(9), 2 + JK(8) = JK8 + IF (POS == 10) THEN IF (RESJ>=ABS(JK8 - J(10)) .AND. RESJ<=JK8+& - J(10)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:90) - WRITE (FIL, 999) RAD2(1:90) - WRITE (FIL, 999) RAD3(1:92) - CF = CF + 1 - ENDIF - ELSE - + J(10)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:90) + WRITE (FIL, 999) RAD2(1:90) + WRITE (FIL, 999) RAD3(1:92) + CF = CF + 1 + ENDIF + ELSE + J(11) = JKVANT(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) + ,I11) S(11) = SENIOR(ORBIT(11),PLUS(11),ANTEL(11)& - ,I11) - DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 - JK(9) = JK9 - IF (POS == 11) THEN + ,I11) + DO JK9 = ABS(JK8 - J(10)), JK8 + J(10), 2 + JK(9) = JK9 + IF (POS == 11) THEN IF (RESJ>=ABS(JK9 - J(11)) .AND. RESJ<=JK9+& - J(11)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:99) - WRITE (FIL, 999) RAD2(1:99) - WRITE (FIL, 999) RAD3(1:101) - CF = CF + 1 - ENDIF - ELSE - + J(11)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:99) + WRITE (FIL, 999) RAD2(1:99) + WRITE (FIL, 999) RAD3(1:101) + CF = CF + 1 + ENDIF + ELSE + J(12) = JKVANT(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) + ,I12) S(12) = SENIOR(ORBIT(12),PLUS(12),ANTEL(12)& - ,I12) - DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 - JK(10) = JK10 - IF (POS == 12) THEN + ,I12) + DO JK10 = ABS(JK9 - J(11)), JK9 + J(11), 2 + JK(10) = JK10 + IF (POS == 12) THEN IF (RESJ>=ABS(JK10 - J(12)) .AND. RESJ<=& - JK10+J(12)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:108) - WRITE (FIL, 999) RAD2(1:108) - WRITE (FIL, 999) RAD3(1:110) - CF = CF + 1 - ENDIF - ELSE - + JK10+J(12)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:108) + WRITE (FIL, 999) RAD2(1:108) + WRITE (FIL, 999) RAD3(1:110) + CF = CF + 1 + ENDIF + ELSE + J(13) = JKVANT(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) S(13) = SENIOR(ORBIT(13),PLUS(13),ANTEL(13)& - ,I13) + ,I13) DO JK11 = ABS(JK10 - J(12)), JK10 + J(12), & - 2 - JK(11) = JK11 - IF (POS == 13) THEN + 2 + JK(11) = JK11 + IF (POS == 13) THEN IF (RESJ>=ABS(JK11 - J(13)) .AND. RESJ<=& - JK11+J(13)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:117) - WRITE (FIL, 999) RAD2(1:117) - WRITE (FIL, 999) RAD3(1:119) - CF = CF + 1 - ENDIF - ELSE - + JK11+J(13)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:117) + WRITE (FIL, 999) RAD2(1:117) + WRITE (FIL, 999) RAD3(1:119) + CF = CF + 1 + ENDIF + ELSE + J(14) = JKVANT(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) S(14) = SENIOR(ORBIT(14),PLUS(14),ANTEL(14)& - ,I14) + ,I14) DO JK12 = ABS(JK11 - J(13)), JK11 + J(13), & - 2 - JK(12) = JK12 - IF (POS == 14) THEN + 2 + JK(12) = JK12 + IF (POS == 14) THEN IF (RESJ>=ABS(JK12 - J(14)) .AND. RESJ<=& - JK12+J(14)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:126) - WRITE (FIL, 999) RAD2(1:126) - WRITE (FIL, 999) RAD3(1:128) - CF = CF + 1 - ENDIF - ELSE - + JK12+J(14)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:126) + WRITE (FIL, 999) RAD2(1:126) + WRITE (FIL, 999) RAD3(1:128) + CF = CF + 1 + ENDIF + ELSE + J(15) = JKVANT(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) S(15) = SENIOR(ORBIT(15),PLUS(15),ANTEL(15)& - ,I15) + ,I15) DO JK13 = ABS(JK12 - J(14)), JK12 + J(14), & - 2 - JK(13) = JK13 - IF (POS == 15) THEN + 2 + JK(13) = JK13 + IF (POS == 15) THEN IF (RESJ>=ABS(JK13 - J(15)) .AND. RESJ<=& - JK13+J(15)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:135) - WRITE (FIL, 999) RAD2(1:135) - WRITE (FIL, 999) RAD3(1:137) - CF = CF + 1 - ENDIF - ELSE - + JK13+J(15)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:135) + WRITE (FIL, 999) RAD2(1:135) + WRITE (FIL, 999) RAD3(1:137) + CF = CF + 1 + ENDIF + ELSE + J(16) = JKVANT(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) S(16) = SENIOR(ORBIT(16),PLUS(16),ANTEL(16)& - ,I16) + ,I16) DO JK14 = ABS(JK13 - J(15)), JK13 + J(15), & - 2 - JK(14) = JK14 - IF (POS == 16) THEN + 2 + JK(14) = JK14 + IF (POS == 16) THEN IF (RESJ>=ABS(JK14 - J(16)) .AND. RESJ<=& - JK14+J(16)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:144) - WRITE (FIL, 999) RAD2(1:144) - WRITE (FIL, 999) RAD3(1:146) - CF = CF + 1 - ENDIF - ELSE - + JK14+J(16)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:144) + WRITE (FIL, 999) RAD2(1:144) + WRITE (FIL, 999) RAD3(1:146) + CF = CF + 1 + ENDIF + ELSE + J(17) = JKVANT(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) S(17) = SENIOR(ORBIT(17),PLUS(17),ANTEL(17)& - ,I17) + ,I17) DO JK15 = ABS(JK14 - J(16)), JK14 + J(16), & - 2 - JK(15) = JK15 - IF (POS == 17) THEN + 2 + JK(15) = JK15 + IF (POS == 17) THEN IF (RESJ>=ABS(JK15 - J(17)) .AND. RESJ<=& - JK15+J(17)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:153) - WRITE (FIL, 999) RAD2(1:153) - WRITE (FIL, 999) RAD3(1:155) - CF = CF + 1 - ENDIF - ELSE - + JK15+J(17)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:153) + WRITE (FIL, 999) RAD2(1:153) + WRITE (FIL, 999) RAD3(1:155) + CF = CF + 1 + ENDIF + ELSE + J(18) = JKVANT(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) S(18) = SENIOR(ORBIT(18),PLUS(18),ANTEL(18)& - ,I18) + ,I18) DO JK16 = ABS(JK15 - J(17)), JK15 + J(17), & - 2 - JK(16) = JK16 - IF (POS == 18) THEN + 2 + JK(16) = JK16 + IF (POS == 18) THEN IF (RESJ>=ABS(JK16 - J(18)) .AND. RESJ<=& - JK16+J(18)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:162) - WRITE (FIL, 999) RAD2(1:162) - WRITE (FIL, 999) RAD3(1:164) - CF = CF + 1 - ENDIF - ELSE - + JK16+J(18)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:162) + WRITE (FIL, 999) RAD2(1:162) + WRITE (FIL, 999) RAD3(1:164) + CF = CF + 1 + ENDIF + ELSE + J(19) = JKVANT(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) S(19) = SENIOR(ORBIT(19),PLUS(19),ANTEL(19)& - ,I19) + ,I19) DO JK17 = ABS(JK16 - J(18)), JK16 + J(18), & - 2 - JK(17) = JK17 - IF (POS == 19) THEN + 2 + JK(17) = JK17 + IF (POS == 19) THEN IF (RESJ>=ABS(JK17 - J(19)) .AND. RESJ<=& - JK17+J(19)) THEN - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:171) - WRITE (FIL, 999) RAD2(1:171) - WRITE (FIL, 999) RAD3(1:173) - CF = CF + 1 - ENDIF - ELSE - + JK17+J(19)) THEN + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:171) + WRITE (FIL, 999) RAD2(1:171) + WRITE (FIL, 999) RAD3(1:173) + CF = CF + 1 + ENDIF + ELSE + J(20) = JKVANT(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) S(20) = SENIOR(ORBIT(20),PLUS(20),ANTEL(20)& - ,I20) + ,I20) DO JK18 = ABS(JK17 - J(19)), JK17 + J(19), & - 2 + 2 IF (RESJJK18+J& - (20)) CYCLE - JK(18) = JK18 - CALL KOPP1 (POS, RAD2, J, S, ANTKO) - CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) - WRITE (FIL, 999) RAD1(1:180) - WRITE (FIL, 999) RAD2(1:180) - WRITE (FIL, 999) RAD3(1:182) - CF = CF + 1 - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - ENDIF - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - END DO - 999 FORMAT(2A) - RETURN - END SUBROUTINE GEN + (20)) CYCLE + JK(18) = JK18 + CALL KOPP1 (POS, RAD2, J, S, ANTKO) + CALL KOPP2 (POS, RAD3, JK, J, PAR, ANTKO) + WRITE (FIL, 999) RAD1(1:180) + WRITE (FIL, 999) RAD2(1:180) + WRITE (FIL, 999) RAD3(1:182) + CF = CF + 1 + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + ENDIF + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + 999 FORMAT(2A) + RETURN + END SUBROUTINE GEN diff --git a/src/appl/rcsfgenerate90/jjgen15b.f90 b/src/appl/rcsfgenerate90/jjgen15b.f90 index 57a273868..b50a66f04 100644 --- a/src/appl/rcsfgenerate90/jjgen15b.f90 +++ b/src/appl/rcsfgenerate90/jjgen15b.f90 @@ -98,26 +98,26 @@ subroutine jjgen15 low,minJ,maxJ,lim,dubbel) call Fivelines(org,lock,closed,.TRUE.,posn,posl) call Blanda(org,varmax,lock,minJ,maxJ,skal,nmax,low, & - posn,posl,lim,dubbel,.TRUE.) + posn,posl,lim,dubbel,.TRUE.) second = .FALSE. endif ii=0 if(.not.second) then call Merge(.TRUE.,posn,posl,ii) if(advexp) ii=ii+1 - call open79(ii) + call open79(ii) endif - do + do call Matbin(org,lock,closed,varmax,skal,second,anel, & - par,low,nmax,lim,dubbel,minJ,maxJ) + par,low,nmax,lim,dubbel,minJ,maxJ) if(.not.second) exit call Fivelines(org,lock,closed,.FALSE.,posn,posl) call Blanda(org,varmax,lock,minJ,maxJ,skal,nmax,low, & - posn,posl,lim,dubbel,.FALSE.) + posn,posl,lim,dubbel,.FALSE.) call Merge(.false.,posn,posl,ii) ii=ii+1 - call open79(ii) + call open79(ii) second = .false. enddo ! write(*,200) 'The merged file is called rcsf.out.' diff --git a/src/appl/rcsfgenerate90/kopp1.f90 b/src/appl/rcsfgenerate90/kopp1.f90 index 37122100c..3e99e33f7 100644 --- a/src/appl/rcsfgenerate90/kopp1.f90 +++ b/src/appl/rcsfgenerate90/kopp1.f90 @@ -1,51 +1,51 @@ ! last edited July 30, 1996 - subroutine kopp1(pos, rad2, j, s, antko) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine kopp1(pos, rad2, j, s, antko) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pos - character , intent(out) :: rad2*200 - integer , intent(in) :: j(20) - integer , intent(in) :: s(20) - integer , intent(in) :: antko(20) + integer , intent(in) :: pos + character , intent(out) :: rad2*200 + integer , intent(in) :: j(20) + integer , intent(in) :: s(20) + integer , intent(in) :: antko(20) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, k, tal + integer :: i, k, tal !----------------------------------------------- - do i = 1, 200 - rad2(i:i) = ' ' - end do - do i = 1, pos - k = 9*i - if (j(i) == 2*(j(i)/2)) then - if (.not.(j(i)==0 .and. antko(i)==1)) then - if (s(i) /= (-1)) then - rad2(k-4:k-4) = ';' - rad2(k-5:k-5) = char(48 + s(i)) - endif - tal = j(i)/20 + do i = 1, 200 + rad2(i:i) = ' ' + end do + do i = 1, pos + k = 9*i + if (j(i) == 2*(j(i)/2)) then + if (.not.(j(i)==0 .and. antko(i)==1)) then + if (s(i) /= (-1)) then + rad2(k-4:k-4) = ';' + rad2(k-5:k-5) = char(48 + s(i)) + endif + tal = j(i)/20 if (tal /= 0) then -!GG rad2(k:k) = char(48 + tal) +!GG rad2(k:k) = char(48 + tal) rad2(k-1:k-1) = char(48+tal) end if - tal = j(i)/2 - tal*10 - rad2(k:k) = char(48 + tal) - endif - else - if (s(i) /= (-1)) then - rad2(k-4:k-4) = ';' - rad2(k-5:k-5) = char(48 + s(i)) - endif - tal = j(i)/10 - if (tal /= 0) rad2(k-3:k-3) = char(48 + tal) - tal = j(i) - tal*10 - rad2(k-2:k-2) = char(48 + tal) - rad2(k-1:k) = '/2' - endif - end do - return - end subroutine kopp1 + tal = j(i)/2 - tal*10 + rad2(k:k) = char(48 + tal) + endif + else + if (s(i) /= (-1)) then + rad2(k-4:k-4) = ';' + rad2(k-5:k-5) = char(48 + s(i)) + endif + tal = j(i)/10 + if (tal /= 0) rad2(k-3:k-3) = char(48 + tal) + tal = j(i) - tal*10 + rad2(k-2:k-2) = char(48 + tal) + rad2(k-1:k) = '/2' + endif + end do + return + end subroutine kopp1 diff --git a/src/appl/rcsfgenerate90/kopp1_I.f90 b/src/appl/rcsfgenerate90/kopp1_I.f90 index 375667777..f96669def 100644 --- a/src/appl/rcsfgenerate90/kopp1_I.f90 +++ b/src/appl/rcsfgenerate90/kopp1_I.f90 @@ -1,12 +1,12 @@ - MODULE kopp1_I + MODULE kopp1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE kopp1 (POS, RAD2, J, S, ANTKO) - integer, INTENT(IN) :: POS - character (LEN = 200), INTENT(OUT) :: RAD2 - integer, DIMENSION(20), INTENT(IN) :: J - integer, DIMENSION(20), INTENT(IN) :: S - integer, DIMENSION(20), INTENT(IN) :: ANTKO - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE kopp1 (POS, RAD2, J, S, ANTKO) + integer, INTENT(IN) :: POS + character (LEN = 200), INTENT(OUT) :: RAD2 + integer, DIMENSION(20), INTENT(IN) :: J + integer, DIMENSION(20), INTENT(IN) :: S + integer, DIMENSION(20), INTENT(IN) :: ANTKO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/kopp2.f90 b/src/appl/rcsfgenerate90/kopp2.f90 index bd362dcdc..a22fab4fc 100644 --- a/src/appl/rcsfgenerate90/kopp2.f90 +++ b/src/appl/rcsfgenerate90/kopp2.f90 @@ -1,70 +1,70 @@ ! last edited July 30, 1996 - subroutine kopp2(pos, rad3, j, jprim, par, antko) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine kopp2(pos, rad3, j, jprim, par, antko) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pos - integer , intent(in) :: par - character , intent(out) :: rad3*200 - integer , intent(in) :: j(20) - integer , intent(in) :: jprim(20) - integer , intent(in) :: antko(20) + integer , intent(in) :: pos + integer , intent(in) :: par + character , intent(out) :: rad3*200 + integer , intent(in) :: j(20) + integer , intent(in) :: jprim(20) + integer , intent(in) :: antko(20) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, k, tal - logical :: first + integer :: i, k, tal + logical :: first !----------------------------------------------- - - first = .TRUE. - do i = 1, 200 - rad3(i:i) = ' ' - end do - i = max(1,pos - 1) - k = 9*pos - 2 - if (j(i) == 2*(j(i)/2)) then - tal = j(i)/20 - if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) - tal = j(i)/2 - tal*10 - rad3(k+3:k+3) = char(48 + tal) - else - tal = j(i)/10 - if (tal /= 0) rad3(k:k) = char(48 + tal) - tal = j(i) - tal*10 - rad3(k+1:k+1) = char(48 + tal) - rad3(k+2:k+3) = '/2' - endif - if (par == 0) then - rad3(k+4:k+4) = '+' - else - rad3(k+4:k+4) = '-' - endif - if (pos > 2) then + + first = .TRUE. + do i = 1, 200 + rad3(i:i) = ' ' + end do + i = max(1,pos - 1) + k = 9*pos - 2 + if (j(i) == 2*(j(i)/2)) then + tal = j(i)/20 + if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) + tal = j(i)/2 - tal*10 + rad3(k+3:k+3) = char(48 + tal) + else + tal = j(i)/10 + if (tal /= 0) rad3(k:k) = char(48 + tal) + tal = j(i) - tal*10 + rad3(k+1:k+1) = char(48 + tal) + rad3(k+2:k+3) = '/2' + endif + if (par == 0) then + rad3(k+4:k+4) = '+' + else + rad3(k+4:k+4) = '-' + endif + if (pos > 2) then if (jprim(1)/=0 .or. .not.(jprim(1)==0 .and. antko(1)==1)) first = & - .FALSE. - do i = 1, pos - 2 + .FALSE. + do i = 1, pos - 2 if (first .and. (jprim(i+1)/=0 .or. jprim(i+1)==0 .and. antko(i+1)& - /=1)) then - first = .FALSE. - else if (.not.first .and. jprim(i+1)/=0) then - k = 9*(i + 1) - if (j(i) == 2*(j(i)/2)) then - tal = j(i)/20 - if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) - tal = j(i)/2 - tal*10 - rad3(k+3:k+3) = char(48 + tal) - else - tal = j(i)/10 - if (tal /= 0) rad3(k:k) = char(48 + tal) - tal = j(i) - tal*10 - rad3(k+1:k+1) = char(48 + tal) - rad3(k+2:k+3) = '/2' - endif - endif - end do - endif - return - end subroutine kopp2 + /=1)) then + first = .FALSE. + else if (.not.first .and. jprim(i+1)/=0) then + k = 9*(i + 1) + if (j(i) == 2*(j(i)/2)) then + tal = j(i)/20 + if (tal /= 0) rad3(k+2:k+2) = char(48 + tal) + tal = j(i)/2 - tal*10 + rad3(k+3:k+3) = char(48 + tal) + else + tal = j(i)/10 + if (tal /= 0) rad3(k:k) = char(48 + tal) + tal = j(i) - tal*10 + rad3(k+1:k+1) = char(48 + tal) + rad3(k+2:k+3) = '/2' + endif + endif + end do + endif + return + end subroutine kopp2 diff --git a/src/appl/rcsfgenerate90/kopp2_I.f90 b/src/appl/rcsfgenerate90/kopp2_I.f90 index f784b8f3c..8de3b034d 100644 --- a/src/appl/rcsfgenerate90/kopp2_I.f90 +++ b/src/appl/rcsfgenerate90/kopp2_I.f90 @@ -1,13 +1,13 @@ - MODULE kopp2_I + MODULE kopp2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE kopp2 (POS, RAD3, J, JPRIM, PAR, ANTKO) - integer, INTENT(IN) :: POS - character (LEN = 200), INTENT(OUT) :: RAD3 - integer, DIMENSION(20), INTENT(IN) :: J - integer, DIMENSION(20), INTENT(IN) :: JPRIM - integer, INTENT(IN) :: PAR - integer, DIMENSION(20), INTENT(IN) :: ANTKO - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE kopp2 (POS, RAD3, J, JPRIM, PAR, ANTKO) + integer, INTENT(IN) :: POS + character (LEN = 200), INTENT(OUT) :: RAD3 + integer, DIMENSION(20), INTENT(IN) :: J + integer, DIMENSION(20), INTENT(IN) :: JPRIM + integer, INTENT(IN) :: PAR + integer, DIMENSION(20), INTENT(IN) :: ANTKO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/lasa1.f90 b/src/appl/rcsfgenerate90/lasa1.f90 index 2ba8a1020..b7a48c23e 100644 --- a/src/appl/rcsfgenerate90/lasa1.f90 +++ b/src/appl/rcsfgenerate90/lasa1.f90 @@ -1,35 +1,35 @@ ! last edited July 31, 1996 - subroutine lasa1(fil, rad, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa1(fil, rad, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reada_I + use reada_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: skal - logical :: slut - character :: rad*200 - integer :: pop(15,0:10,0:1) + integer , intent(in) :: fil + integer :: skal + logical :: slut + character :: rad*200 + integer :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i + integer :: i !----------------------------------------------- - if (.not.slut) then - do i = 1, 200 - rad(i:i) = ' ' - end do - read (fil, 999, end=10) rad - call reada (rad, pop, skal, slut) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa1 + if (.not.slut) then + do i = 1, 200 + rad(i:i) = ' ' + end do + read (fil, 999, end=10) rad + call reada (rad, pop, skal, slut) + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa1 diff --git a/src/appl/rcsfgenerate90/lasa1_I.f90 b/src/appl/rcsfgenerate90/lasa1_I.f90 index b00777eeb..c4c17035e 100644 --- a/src/appl/rcsfgenerate90/lasa1_I.f90 +++ b/src/appl/rcsfgenerate90/lasa1_I.f90 @@ -1,12 +1,12 @@ - MODULE lasa1_I + MODULE lasa1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lasa1 (FIL, RAD, POP, SKAL, SLUT) - integer, INTENT(IN) :: FIL - character (LEN = 200), INTENT(OUT) :: RAD - integer, DIMENSION(15,0:10,0:1) :: POP - integer :: SKAL - logical, INTENT(INOUT) :: SLUT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lasa1 (FIL, RAD, POP, SKAL, SLUT) + integer, INTENT(IN) :: FIL + character (LEN = 200), INTENT(OUT) :: RAD + integer, DIMENSION(15,0:10,0:1) :: POP + integer :: SKAL + logical, INTENT(INOUT) :: SLUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/lasa2.f90 b/src/appl/rcsfgenerate90/lasa2.f90 index 3c95d470d..e4b3bcedc 100644 --- a/src/appl/rcsfgenerate90/lasa2.f90 +++ b/src/appl/rcsfgenerate90/lasa2.f90 @@ -1,26 +1,26 @@ ! last edited July 30, 1996 - subroutine lasa2(fil, rad2, rad3, stopp, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa2(fil, rad2, rad3, stopp, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: stopp - logical , intent(inout) :: slut - character :: rad2*200 - character :: rad3*200 + integer , intent(in) :: fil + integer :: stopp + logical , intent(inout) :: slut + character :: rad2*200 + character :: rad3*200 !----------------------------------------------- - if (.not.slut) then - read (fil, 999, end=10) rad2 + if (.not.slut) then + read (fil, 999, end=10) rad2 ! read(fil,999,end=10) rad2(1:stopp) - read (fil, 999, end=10) rad3 + read (fil, 999, end=10) rad3 ! read(fil,999,end=10) rad3(1:stopp+4) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa2 + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa2 diff --git a/src/appl/rcsfgenerate90/lasa2_I.f90 b/src/appl/rcsfgenerate90/lasa2_I.f90 index 5357eca51..86fe8dc69 100644 --- a/src/appl/rcsfgenerate90/lasa2_I.f90 +++ b/src/appl/rcsfgenerate90/lasa2_I.f90 @@ -1,14 +1,14 @@ - MODULE lasa2_I + MODULE lasa2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lasa2 (FIL, RAD2, RAD3, STOPP, SLUT) - integer, INTENT(IN) :: FIL - character (LEN = 200) :: RAD2 - character (LEN = 200) :: RAD3 - integer :: STOPP +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lasa2 (FIL, RAD2, RAD3, STOPP, SLUT) + integer, INTENT(IN) :: FIL + character (LEN = 200) :: RAD2 + character (LEN = 200) :: RAD3 + integer :: STOPP !VAST...Dummy argument STOPP is not referenced in this routine. - logical, INTENT(INOUT) :: SLUT + logical, INTENT(INOUT) :: SLUT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/lasax-reada.f90 b/src/appl/rcsfgenerate90/lasax-reada.f90 index 4f25dca4c..e5a621628 100644 --- a/src/appl/rcsfgenerate90/lasax-reada.f90 +++ b/src/appl/rcsfgenerate90/lasax-reada.f90 @@ -1,140 +1,140 @@ ! last edited July 31, 1996 - subroutine lasa1(fil, rad, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa1(fil, rad, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use reada_I + use reada_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: skal - logical :: slut - character :: rad*200 - integer :: pop(15,0:10,0:1) + integer , intent(in) :: fil + integer :: skal + logical :: slut + character :: rad*200 + integer :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i + integer :: i !----------------------------------------------- - if (.not.slut) then - do i = 1, 200 - rad(i:i) = ' ' - end do - read (fil, 999, end=10) rad - call reada (rad, pop, skal, slut) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa1 + if (.not.slut) then + do i = 1, 200 + rad(i:i) = ' ' + end do + read (fil, 999, end=10) rad + call reada (rad, pop, skal, slut) + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa1 ! last edited July 30, 1996 - subroutine lasa2(fil, rad2, rad3, stopp, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lasa2(fil, rad2, rad3, stopp, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: fil - integer :: stopp - logical , intent(inout) :: slut - character :: rad2*200 - character :: rad3*200 + integer , intent(in) :: fil + integer :: stopp + logical , intent(inout) :: slut + character :: rad2*200 + character :: rad3*200 !----------------------------------------------- - if (.not.slut) then - read (fil, 999, end=10) rad2 + if (.not.slut) then + read (fil, 999, end=10) rad2 ! read(fil,999,end=10) rad2(1:stopp) - read (fil, 999, end=10) rad3 + read (fil, 999, end=10) rad3 ! read(fil,999,end=10) rad3(1:stopp+4) - return - endif - 10 continue - slut = .TRUE. - 999 format(a) - return - end subroutine lasa2 + return + endif + 10 continue + slut = .TRUE. + 999 format(a) + return + end subroutine lasa2 ! last edited July 31, 1996 - subroutine reada(rad1, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reada(rad1, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: skal - logical , intent(out) :: slut - character , intent(in) :: rad1*200 - integer , intent(out) :: pop(15,0:10,0:1) + integer , intent(inout) :: skal + logical , intent(out) :: slut + character , intent(in) :: rad1*200 + integer , intent(out) :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k, n, l, antal, stopp - character, dimension(0:10) :: orb + integer :: i, j, k, n, l, antal, stopp + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - slut = .FALSE. - do n = 1, 15 - pop(n,:min(10,n-1),:1) = 0 - end do - stopp = skal - 1 - l10: do i = 0, stopp - j = 9*i - if (rad1(j+3:j+3) == ' ') return - skal = i + 1 - slut = .TRUE. - n = ichar(rad1(j+3:j+3)) - ichar('0') - if (rad1(j+2:j+2) == '1') n = n + 10 - if (n<=15 .and. n>=1) then - if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 0 - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - else - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - endif - else - slut = .TRUE. - return - endif - end do l10 - return - end subroutine reada + 'n'/ + slut = .FALSE. + do n = 1, 15 + pop(n,:min(10,n-1),:1) = 0 + end do + stopp = skal - 1 + l10: do i = 0, stopp + j = 9*i + if (rad1(j+3:j+3) == ' ') return + skal = i + 1 + slut = .TRUE. + n = ichar(rad1(j+3:j+3)) - ichar('0') + if (rad1(j+2:j+2) == '1') n = n + 10 + if (n<=15 .and. n>=1) then + if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 0 + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + else + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + endif + else + slut = .TRUE. + return + endif + end do l10 + return + end subroutine reada diff --git a/src/appl/rcsfgenerate90/lika.f90 b/src/appl/rcsfgenerate90/lika.f90 index 209744dc4..d0875ebb2 100644 --- a/src/appl/rcsfgenerate90/lika.f90 +++ b/src/appl/rcsfgenerate90/lika.f90 @@ -1,30 +1,30 @@ - + ! last edited September 23, 1995 - logical function lika (pop0, pop1) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + logical function lika (pop0, pop1) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: pop0(15,0:10,0:1) - integer , intent(in) :: pop1(15,0:10,0:1) + integer , intent(in) :: pop0(15,0:10,0:1) + integer , intent(in) :: pop1(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k - logical :: dum + integer :: i, j, k + logical :: dum !----------------------------------------------- - dum = .TRUE. - l10: do i = 1, 15 - do j = 0, min(10,i - 1) - do k = 0, 1 - dum = dum .and. pop0(i,j,k)==pop1(i,j,k) - if (dum) cycle - exit l10 - end do - end do - end do l10 - lika = dum - return - end function lika + dum = .TRUE. + l10: do i = 1, 15 + do j = 0, min(10,i - 1) + do k = 0, 1 + dum = dum .and. pop0(i,j,k)==pop1(i,j,k) + if (dum) cycle + exit l10 + end do + end do + end do l10 + lika = dum + return + end function lika diff --git a/src/appl/rcsfgenerate90/lika_I.f90 b/src/appl/rcsfgenerate90/lika_I.f90 index ebe5be67d..7a8d38d2b 100644 --- a/src/appl/rcsfgenerate90/lika_I.f90 +++ b/src/appl/rcsfgenerate90/lika_I.f90 @@ -1,9 +1,9 @@ - MODULE lika_I + MODULE lika_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - LOGICAL FUNCTION lika (POP0, POP1) - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP0 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 - END FUNCTION - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + LOGICAL FUNCTION lika (POP0, POP1) + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP0 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/lockad.f90 b/src/appl/rcsfgenerate90/lockad.f90 index 898a34310..972362573 100644 --- a/src/appl/rcsfgenerate90/lockad.f90 +++ b/src/appl/rcsfgenerate90/lockad.f90 @@ -1,80 +1,80 @@ ! last edited Februar 20, 1996 - subroutine lockad(closed, med, slut, expand) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine lockad(closed, med, slut, expand) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - logical , intent(out) :: slut - logical , intent(in) :: expand - logical , intent(out) :: closed(15,0:10) - logical , intent(out) :: med(15,0:10) + logical , intent(out) :: slut + logical , intent(in) :: expand + logical , intent(out) :: closed(15,0:10) + logical , intent(out) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, n, l - character :: rad*1000 - character, dimension(0:10) :: orb + integer :: i, j, n, l + character :: rad*1000 + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - if (expand) then - read (fil_2, *, end=40) - read (fil_2, 100, end=40) rad - else - read (fil_1, *, end=40) - read (fil_1, 100, end=40) rad - endif - do n = 1, 15 - closed(n,1:min(10,n-1)) = .FALSE. - end do - l30: do i = 0, 205 - j = i*5 - n = ichar(rad(j+3:j+3)) - ichar('0') - if (n>=1 .and. n<=15) then - do l = 0, min(10,n - 1) - if (rad(j+4:j+4) /= orb(l)) cycle - closed(n,l) = .TRUE. - cycle l30 - end do - else - exit l30 - endif - end do l30 - if (expand) then - read (fil_2, *, end=40) - read (fil_2, 100, end=40) rad - else - read (fil_1, *, end=40) - read (fil_1, 100, end=40) rad - endif - do n = 1, 15 - med(n,1:min(10,n-1)) = .FALSE. - end do - l130: do i = 0, 205 - j = i*5 - n = ichar(rad(j+3:j+3)) - ichar('0') - if (n>=1 .and. n<=15) then - do l = 0, min(10,n - 1) - if (rad(j+4:j+4) /= orb(l)) cycle - med(n,l) = .TRUE. - cycle l130 - end do - else - return - endif - end do l130 - - return - 40 continue - slut = .TRUE. - return - 100 format(a) - return - end subroutine lockad + 'n'/ + if (expand) then + read (fil_2, *, end=40) + read (fil_2, 100, end=40) rad + else + read (fil_1, *, end=40) + read (fil_1, 100, end=40) rad + endif + do n = 1, 15 + closed(n,1:min(10,n-1)) = .FALSE. + end do + l30: do i = 0, 205 + j = i*5 + n = ichar(rad(j+3:j+3)) - ichar('0') + if (n>=1 .and. n<=15) then + do l = 0, min(10,n - 1) + if (rad(j+4:j+4) /= orb(l)) cycle + closed(n,l) = .TRUE. + cycle l30 + end do + else + exit l30 + endif + end do l30 + if (expand) then + read (fil_2, *, end=40) + read (fil_2, 100, end=40) rad + else + read (fil_1, *, end=40) + read (fil_1, 100, end=40) rad + endif + do n = 1, 15 + med(n,1:min(10,n-1)) = .FALSE. + end do + l130: do i = 0, 205 + j = i*5 + n = ichar(rad(j+3:j+3)) - ichar('0') + if (n>=1 .and. n<=15) then + do l = 0, min(10,n - 1) + if (rad(j+4:j+4) /= orb(l)) cycle + med(n,l) = .TRUE. + cycle l130 + end do + else + return + endif + end do l130 + + return + 40 continue + slut = .TRUE. + return + 100 format(a) + return + end subroutine lockad diff --git a/src/appl/rcsfgenerate90/lockad_I.f90 b/src/appl/rcsfgenerate90/lockad_I.f90 index 13328f6cd..8ef63330e 100644 --- a/src/appl/rcsfgenerate90/lockad_I.f90 +++ b/src/appl/rcsfgenerate90/lockad_I.f90 @@ -1,12 +1,12 @@ - MODULE lockad_I + MODULE lockad_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE lockad (CLOSED, MED, SLUT, EXPAND) - logical, DIMENSION(15,0:10), INTENT(OUT) :: CLOSED - logical, DIMENSION(15,0:10), INTENT(OUT) :: MED - logical, INTENT(OUT) :: SLUT - logical, INTENT(IN) :: EXPAND +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE lockad (CLOSED, MED, SLUT, EXPAND) + logical, DIMENSION(15,0:10), INTENT(OUT) :: CLOSED + logical, DIMENSION(15,0:10), INTENT(OUT) :: MED + logical, INTENT(OUT) :: SLUT + logical, INTENT(IN) :: EXPAND !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/matain.f90 b/src/appl/rcsfgenerate90/matain.f90 index c92424898..53f7ca7b9 100644 --- a/src/appl/rcsfgenerate90/matain.f90 +++ b/src/appl/rcsfgenerate90/matain.f90 @@ -103,7 +103,7 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & if (nmax.LT.10) then write(*,200) & 'Highest n-number in reference configuration? (1..', nmax,')' - else + else write(*,202) & 'Highest n-number in reference configuration? (1..', nmax,')' endif @@ -256,7 +256,7 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & dubbel(i,j) = Y(1:1).EQ.'d' .OR. & Y(1:1).EQ.'D' endif - lock(i,j) = Y(1:1).EQ.'i' .OR. Y(1:1).EQ.'I' + lock(i,j) = Y(1:1).EQ.'i' .OR. Y(1:1).EQ.'I' closed(i,j) = .FALSE. endif if (Y(1:1).GE.'0' .AND. Y(1:1).LE.'9') then @@ -286,7 +286,7 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & read(193,1000) X write(logfil,*) X,i,orb(j),' inactive, active, etc...' dubbel(i,j) = X.EQ.'d' .OR. X.EQ.'D' - lock(i,j) = X.EQ.'i' .OR. X.EQ.'I' + lock(i,j) = X.EQ.'i' .OR. X.EQ.'I' endif elseif (org(i,j).NE.0) then write(*,204) i,orb(j),' is part of the predefined core.' @@ -318,7 +318,7 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & endif endif endif - if (.NOT. lock(i,j)) anela = anela + org(i,j) + if (.NOT. lock(i,j)) anela = anela + org(i,j) else lock(i,j) = closed(i,j) endif @@ -336,7 +336,7 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & 160 continue 1100 write(*,400) 'Resulting 2*J-number? lower, higher ', & '(J=1 -> 2*J=2 etc.)' - read(193,*,ERR=1100) minJ,maxJ + read(193,*,ERR=1100) minJ,maxJ if (anel .EQ. 2*(anel/2)) then if (minJ .NE. 2*(minJ/2) .OR. maxJ .NE. 2*(maxJ/2)) then write(*,*) 'The resulting 2*J-numbers should be even' @@ -375,4 +375,4 @@ subroutine matain(org, lock, closed, varmax, skal, nmax, anel, par, low, & 2000 format(I1,2A) 3000 format(A,I2,2A) return - end + end diff --git a/src/appl/rcsfgenerate90/matain_I.f90 b/src/appl/rcsfgenerate90/matain_I.f90 index 5a9c7b3ff..59491ef72 100644 --- a/src/appl/rcsfgenerate90/matain_I.f90 +++ b/src/appl/rcsfgenerate90/matain_I.f90 @@ -1,22 +1,22 @@ - MODULE matain_I + MODULE matain_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 12:22:13 1/ 2/07 +!...Generated by Pacific-Sierra Research 77to90 4.3E 12:22:13 1/ 2/07 SUBROUTINE matain (ORG, LOCK, CLOSED, VARMAX, SKAL, NMAX, ANEL, PAR, LOW& - , MINJ, MAXJ, LIM, DUBBEL) - INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK - LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED - INTEGER, INTENT(IN) :: VARMAX - INTEGER, INTENT(OUT) :: SKAL - INTEGER, INTENT(OUT) :: NMAX - INTEGER, INTENT(OUT) :: ANEL - INTEGER, INTENT(OUT) :: PAR - INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: LOW - INTEGER, INTENT(IN) :: MINJ - INTEGER, INTENT(IN) :: MAXJ - INTEGER, DIMENSION(15), INTENT(INOUT) :: LIM - LOGICAL, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL + , MINJ, MAXJ, LIM, DUBBEL) + INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK + LOGICAL, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED + INTEGER, INTENT(IN) :: VARMAX + INTEGER, INTENT(OUT) :: SKAL + INTEGER, INTENT(OUT) :: NMAX + INTEGER, INTENT(OUT) :: ANEL + INTEGER, INTENT(OUT) :: PAR + INTEGER, DIMENSION(15,0:10), INTENT(INOUT) :: LOW + INTEGER, INTENT(IN) :: MINJ + INTEGER, INTENT(IN) :: MAXJ + INTEGER, DIMENSION(15), INTENT(INOUT) :: LIM + LOGICAL, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/matbin.f90 b/src/appl/rcsfgenerate90/matbin.f90 index df603c8f1..63fafd758 100644 --- a/src/appl/rcsfgenerate90/matbin.f90 +++ b/src/appl/rcsfgenerate90/matbin.f90 @@ -1,263 +1,263 @@ ! last edited August 2, 1996 subroutine matbin(org, lock, closed, varmax, skal, second, anel0, par0, & - low, nmax, lim, dubbel, minj, maxj) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + low, nmax, lim, dubbel, minj, maxj) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer , intent(out) :: skal - integer , intent(in) :: anel0 - integer , intent(out) :: par0 - integer :: nmax - integer :: minj - integer :: maxj - logical , intent(inout) :: second - integer :: org(15,0:10) - integer , intent(inout) :: low(15,0:10) - integer :: lim(15) - logical , intent(inout) :: lock(15,0:10) - logical , intent(inout) :: closed(15,0:10) - logical , intent(out) :: dubbel(15,0:10) + integer :: varmax + integer , intent(out) :: skal + integer , intent(in) :: anel0 + integer , intent(out) :: par0 + integer :: nmax + integer :: minj + integer :: maxj + logical , intent(inout) :: second + integer :: org(15,0:10) + integer , intent(inout) :: low(15,0:10) + integer :: lim(15) + logical , intent(inout) :: lock(15,0:10) + logical , intent(inout) :: closed(15,0:10) + logical , intent(out) :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- integer :: anel, par, i, j, lmax, em, nenter, anela, anelb, block, mshell& - , tmp - logical :: all, lima - character :: x - character , dimension(0:10) :: orb - character , dimension(0:20) :: l - character :: y*2 + , tmp + logical :: all, lima + character :: x + character , dimension(0:10) :: orb + character , dimension(0:20) :: l + character :: y*2 !----------------------------------------------- ! data (l(i),i=0,20)/ 'S', 'P', 'D', 'F', 'G', 'H', 'I', 'K', 'L', 'M', 'N'& - , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ + , 'O', 'Q', 'R', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - - 40 continue - if (.not.second) then - write (*, 200) 'Generate another list? (y/*)' - read (193, 1000) x - second = x=='y' .or. x=='Y' - write (logfil, *) second, ' Generate another list.' - if (.not.second) return - endif - anel = 0 - anela = 0 - anelb = 0 - par = 0 - skal = 20 - 60 continue - write (*, 200) 'Highest n-number? (1..15)' - read (193, *, err=60) nmax - nmax = max(nmax,1) - nmax = min(nmax,15) - write (logfil, *) nmax, ' Highest principal quantum number.' - 70 continue - write (*, 400) 'Highest l-number? (s..', orb(min(10,nmax-1)), ')' - read (193, 1000) x - lmax = -1 - do i = 0, min(10,nmax - 1) - if (x /= orb(i)) cycle - lmax = i - end do - if (lmax == (-1)) go to 70 - write (logfil, *) lmax, ' Highest orbital angular momentum.' - write (*, 200) 'Are all these nl-subshells active? (n/*)' - read (193, 1000) x - all = .not.(x=='n' .or. x=='N') - write (logfil, *) all, ' all subshells active.' - lim = 0 - if (nmax >= 2) then - write (*, 200) 'Limitations on population of n-subshells? (y/*)' - read (193, 1000) x - lima = x=='y' .or. x=='Y' - write (logfil, *) lima, ' limitations on population of n-subshells.' - if (lima) then - mshell = 0 - do i = 1, nmax - 1 - mshell = mshell + 2*i*i - 83 continue - if (i == 1) then - write (*, 200) 'Minimum number of electrons with n=1? (0..2)' - else if (i < 10) then - if (mshell < 100) then + 'n'/ + + 40 continue + if (.not.second) then + write (*, 200) 'Generate another list? (y/*)' + read (193, 1000) x + second = x=='y' .or. x=='Y' + write (logfil, *) second, ' Generate another list.' + if (.not.second) return + endif + anel = 0 + anela = 0 + anelb = 0 + par = 0 + skal = 20 + 60 continue + write (*, 200) 'Highest n-number? (1..15)' + read (193, *, err=60) nmax + nmax = max(nmax,1) + nmax = min(nmax,15) + write (logfil, *) nmax, ' Highest principal quantum number.' + 70 continue + write (*, 400) 'Highest l-number? (s..', orb(min(10,nmax-1)), ')' + read (193, 1000) x + lmax = -1 + do i = 0, min(10,nmax - 1) + if (x /= orb(i)) cycle + lmax = i + end do + if (lmax == (-1)) go to 70 + write (logfil, *) lmax, ' Highest orbital angular momentum.' + write (*, 200) 'Are all these nl-subshells active? (n/*)' + read (193, 1000) x + all = .not.(x=='n' .or. x=='N') + write (logfil, *) all, ' all subshells active.' + lim = 0 + if (nmax >= 2) then + write (*, 200) 'Limitations on population of n-subshells? (y/*)' + read (193, 1000) x + lima = x=='y' .or. x=='Y' + write (logfil, *) lima, ' limitations on population of n-subshells.' + if (lima) then + mshell = 0 + do i = 1, nmax - 1 + mshell = mshell + 2*i*i + 83 continue + if (i == 1) then + write (*, 200) 'Minimum number of electrons with n=1? (0..2)' + else if (i < 10) then + if (mshell < 100) then write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..', mshell, ')' - else + '? (0..', mshell, ')' + else write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - else + '? (0..)' + endif + else write (*, 202) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - read (193, *, err=83) lim(i) - lim(i) = min0(mshell,lim(i)) + '? (0..)' + endif + read (193, *, err=83) lim(i) + lim(i) = min0(mshell,lim(i)) write (logfil, *) lim(i), & - ' is minimum number of electrons with n =', i - end do - endif - endif - 95 continue - if (nmax < 10) then + ' is minimum number of electrons with n =', i + end do + endif + endif + 95 continue + if (nmax < 10) then write (*, 200) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - else + nmax, ')' + else write (*, 202) 'Highest n-number in reference configuration? (1..', & - nmax, ')' - endif - read (193, *, err=95) nenter - nenter = max(nenter,1) - nenter = min(nenter,nmax) - write (logfil, *) nenter, ' highest n-number.' - block = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - low(i,j) = 0 - dubbel(i,j) = .FALSE. - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - if (nenter >= i) then - em = 2 + 4*j - if (em < 10) then - 100 continue - if (i <= 9) then + nmax, ')' + endif + read (193, *, err=95) nenter + nenter = max(nenter,1) + nenter = min(nenter,nmax) + write (logfil, *) nenter, ' highest n-number.' + block = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + low(i,j) = 0 + dubbel(i,j) = .FALSE. + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + if (nenter >= i) then + em = 2 + 4*j + if (em < 10) then + 100 continue + if (i <= 9) then write (*, 200) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 202) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (193, *, err=100) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 100 - else - 101 continue - if (i < 10) then + '? (0..', em, ')' + endif + read (193, *, err=100) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 100 + else + 101 continue + if (i < 10) then write (*, 201) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - else + '? (0..', em, ')' + else write (*, 203) 'Number of electrons in ', i, orb(j), & - '? (0..', em, ')' - endif - read (193, *, err=101) org(i,j) - if (org(i,j)<0 .or. org(i,j)>em) go to 101 - endif + '? (0..', em, ')' + endif + read (193, *, err=101) org(i,j) + if (org(i,j)<0 .or. org(i,j)>em) go to 101 + endif write (logfil, *) org(i,j), ' number of electrons in', i, orb& - (j) - if (all) then - lock(i,j) = .FALSE. - else - if (org(i,j) > 1) then - if (org(i,j) <= 10) then + (j) + if (all) then + lock(i,j) = .FALSE. + else + if (org(i,j) > 1) then + if (org(i,j) <= 10) then write (*, 201) & 'Inactive, active or minimum? (i/*/0..', org(i,j)& - - 1, ')' - else + - 1, ')' + else write (*, 202) & 'Inactive, active or minimum? (i/*/0..', org(i,j)& - - 1, ')' - endif - read (193, 1000) y - else if (org(i,j) == 1) then - write (*, 201) 'Inactive or active? (i/*)' - read (193, 1000) y - else + - 1, ')' + endif + read (193, 1000) y + else if (org(i,j) == 1) then + write (*, 201) 'Inactive or active? (i/*)' + read (193, 1000) y + else write (*, 400) 'Inactive, active or doubled ', & - 'excited? (i/*/d)' - read (193, 1000) y - dubbel(i,j) = y(1:1)=='d' .or. y(1:1)=='D' - endif - lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' - if (y(1:1)>='0' .and. y(1:1)<='9') then - if (org(i,j) > 0) then - tmp = ichar(y(1:1)) - ichar('0') + 'excited? (i/*/d)' + read (193, 1000) y + dubbel(i,j) = y(1:1)=='d' .or. y(1:1)=='D' + endif + lock(i,j) = y(1:1)=='i' .or. y(1:1)=='I' + if (y(1:1)>='0' .and. y(1:1)<='9') then + if (org(i,j) > 0) then + tmp = ichar(y(1:1)) - ichar('0') if (y(2:2)>='1' .and. y(2:2)<='9') tmp = tmp*10 + & - ichar(y(2:2)) - ichar('0') - low(i,j) = min(org(i,j),tmp) - endif - endif - write (logfil, 1000) y, ' inactive, active, etc...' - endif - if (.not.lock(i,j)) anela = anela + org(i,j) - anel = anel + org(i,j) - par = mod(par + j*org(i,j),2) - else if (all) then - org(i,j) = 0 - lock(i,j) = .FALSE. - else - org(i,j) = 0 - closed(i,j) = .FALSE. - if (i < 10) then + ichar(y(2:2)) - ichar('0') + low(i,j) = min(org(i,j),tmp) + endif + endif + write (logfil, 1000) y, ' inactive, active, etc...' + endif + if (.not.lock(i,j)) anela = anela + org(i,j) + anel = anel + org(i,j) + par = mod(par + j*org(i,j),2) + else if (all) then + org(i,j) = 0 + lock(i,j) = .FALSE. + else + org(i,j) = 0 + closed(i,j) = .FALSE. + if (i < 10) then write (*, 204) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - else + 'doubled excited? (i/*/d)' + else write (*, 205) i, orb(j), ' inactive, active or ', & - 'doubled excited? (i/*/d)' - endif - read (193, 1000) x - dubbel(i,j) = x=='d' .or. x=='D' - lock(i,j) = x=='i' .or. x=='I' - write (logfil, *) x, i, orb(j), ' inactive, active, etc...' - endif - else - org(i,j) = 0 - lock(i,j) = .TRUE. - if (closed(i,j)) then - if (i < 10) then - write (*, 204) i, orb(j), ' is a closed shell.' - else - write (*, 205) i, orb(j), ' is a closed shell.' - endif - em = 2 + 4*j - anel = anel + em - block = block + em - endif - endif - anelb = anelb + low(i,j) - end do - lim(i) = lim(i) - block - lim(i) = max0(0,lim(i)) - end do - if (anel /= anel0) then - if (anel0 < 10) then + 'doubled excited? (i/*/d)' + endif + read (193, 1000) x + dubbel(i,j) = x=='d' .or. x=='D' + lock(i,j) = x=='i' .or. x=='I' + write (logfil, *) x, i, orb(j), ' inactive, active, etc...' + endif + else + org(i,j) = 0 + lock(i,j) = .TRUE. + if (closed(i,j)) then + if (i < 10) then + write (*, 204) i, orb(j), ' is a closed shell.' + else + write (*, 205) i, orb(j), ' is a closed shell.' + endif + em = 2 + 4*j + anel = anel + em + block = block + em + endif + endif + anelb = anelb + low(i,j) + end do + lim(i) = lim(i) - block + lim(i) = max0(0,lim(i)) + end do + if (anel /= anel0) then + if (anel0 < 10) then write (*, 300) 'Wrong number of electrons. The first list had ', & - anel0, ' electrons.' - else + anel0, ' electrons.' + else write (*, 301) 'Wrong number of electrons. The first list had ', & - anel0, ' electrons.' - endif - if (anel < 10) then - write (*, 300) 'This list has ', anel, ' electrons.' - else - write (*, 301) 'This list has ', anel, ' electrons.' - endif - second = .FALSE. - go to 40 - endif - 1100 continue + anel0, ' electrons.' + endif + if (anel < 10) then + write (*, 300) 'This list has ', anel, ' electrons.' + else + write (*, 301) 'This list has ', anel, ' electrons.' + endif + second = .FALSE. + go to 40 + endif + 1100 continue write (*, 400) 'Resulting 2*J-number? lower, higher ', & - '(J=1 -> 2*J=2 etc.)' - read (193, *, err=1100) minj, maxj - if (anel == 2*(anel/2)) then - if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be even' - go to 1100 - endif - else - if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then - write (*, *) 'The resulting 2*J-numbers should be odd' - go to 1100 - endif - endif - write (logfil, *) minj, ' to', maxj, ' is the resulting term.' + '(J=1 -> 2*J=2 etc.)' + read (193, *, err=1100) minj, maxj + if (anel == 2*(anel/2)) then + if (minj/=2*(minj/2) .or. maxj/=2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be even' + go to 1100 + endif + else + if (minj==2*(minj/2) .or. maxj==2*(maxj/2)) then + write (*, *) 'The resulting 2*J-numbers should be odd' + go to 1100 + endif + endif + write (logfil, *) minj, ' to', maxj, ' is the resulting term.' ! if (par.NE.par0) then ! write(*,200) 'Wrong parity.' ! if (par0.EQ.0) write(*,*) @@ -267,30 +267,30 @@ subroutine matbin(org, lock, closed, varmax, skal, second, anel0, par0, & ! second = .FALSE. ! goto 40 ! endif - par0 = par - anelb = anela - anelb - 1200 continue - if (anelb < 10) then - write (*, 200) 'Number of excitations = ? (0..', anelb, ')' - read (193, *, err=1200) varmax - else - write (*, 202) 'Number of excitations = ? (0..', anelb, ')' - read (193, *, err=1200) varmax - endif - write (logfil, *) varmax, ' number of excitations.' - 200 format(' ',a,i1,a,a,i1,a) - 201 format(' ',a,i1,a,a,i2,a) - 202 format(' ',a,i2,a,a,i1,a) - 203 format(' ',a,i2,a,a,i2,a) - 204 format(' ',i1,3a) - 205 format(' ',i2,3a) - 208 format(' ',a,i1,a,i2,a) - 300 format(' ',a,i1,a) - 301 format(' ',a,i2,a) - 400 format(' ',3a) - 401 format(' ',2a,i1,a) - 402 format(' ',2a,i2,a) - 1000 format(a,a,a) - 2000 format(i1,a) - return - end subroutine matbin + par0 = par + anelb = anela - anelb + 1200 continue + if (anelb < 10) then + write (*, 200) 'Number of excitations = ? (0..', anelb, ')' + read (193, *, err=1200) varmax + else + write (*, 202) 'Number of excitations = ? (0..', anelb, ')' + read (193, *, err=1200) varmax + endif + write (logfil, *) varmax, ' number of excitations.' + 200 format(' ',a,i1,a,a,i1,a) + 201 format(' ',a,i1,a,a,i2,a) + 202 format(' ',a,i2,a,a,i1,a) + 203 format(' ',a,i2,a,a,i2,a) + 204 format(' ',i1,3a) + 205 format(' ',i2,3a) + 208 format(' ',a,i1,a,i2,a) + 300 format(' ',a,i1,a) + 301 format(' ',a,i2,a) + 400 format(' ',3a) + 401 format(' ',2a,i1,a) + 402 format(' ',2a,i2,a) + 1000 format(a,a,a) + 2000 format(i1,a) + return + end subroutine matbin diff --git a/src/appl/rcsfgenerate90/matbin_I.f90 b/src/appl/rcsfgenerate90/matbin_I.f90 index 7cfa8d000..399d48209 100644 --- a/src/appl/rcsfgenerate90/matbin_I.f90 +++ b/src/appl/rcsfgenerate90/matbin_I.f90 @@ -1,23 +1,23 @@ - MODULE matbin_I + MODULE matbin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE matbin (ORG, LOCK, CLOSED, VARMAX, SKAL, SECOND, ANEL0, PAR0& - , LOW, NMAX, LIM, DUBBEL, MINJ, MAXJ) - integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG - logical, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK - logical, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED - integer, INTENT(IN) :: VARMAX - integer, INTENT(OUT) :: SKAL - logical, INTENT(INOUT) :: SECOND - integer, INTENT(IN) :: ANEL0 - integer, INTENT(OUT) :: PAR0 - integer, DIMENSION(15,0:10), INTENT(INOUT) :: LOW - integer, INTENT(OUT) :: NMAX - integer, DIMENSION(15), INTENT(INOUT) :: LIM - logical, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ + , LOW, NMAX, LIM, DUBBEL, MINJ, MAXJ) + integer, DIMENSION(15,0:10), INTENT(INOUT) :: ORG + logical, DIMENSION(15,0:10), INTENT(INOUT) :: LOCK + logical, DIMENSION(15,0:10), INTENT(INOUT) :: CLOSED + integer, INTENT(IN) :: VARMAX + integer, INTENT(OUT) :: SKAL + logical, INTENT(INOUT) :: SECOND + integer, INTENT(IN) :: ANEL0 + integer, INTENT(OUT) :: PAR0 + integer, DIMENSION(15,0:10), INTENT(INOUT) :: LOW + integer, INTENT(OUT) :: NMAX + integer, DIMENSION(15), INTENT(INOUT) :: LIM + logical, DIMENSION(15,0:10), INTENT(OUT) :: DUBBEL + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/matcin.f90 b/src/appl/rcsfgenerate90/matcin.f90 index 8e06d3784..0376e4b24 100644 --- a/src/appl/rcsfgenerate90/matcin.f90 +++ b/src/appl/rcsfgenerate90/matcin.f90 @@ -1,188 +1,188 @@ ! last edited July 31, 1996 subroutine matcin(lock, closed, med, varmax, cfmax, nmax, minj, maxj, lim& - ) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + ) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: varmax - integer :: cfmax - integer :: nmax - integer :: minj - integer :: maxj - integer :: lim(15) - logical , intent(out) :: lock(15,0:10) - logical , intent(in) :: closed(15,0:10) - logical , intent(in) :: med(15,0:10) + integer :: varmax + integer :: cfmax + integer :: nmax + integer :: minj + integer :: maxj + integer :: lim(15) + logical , intent(out) :: lock(15,0:10) + logical , intent(in) :: closed(15,0:10) + logical , intent(in) :: med(15,0:10) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 + integer, parameter :: logfil = 31 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, lmax, nmaks, mshell, lmaks, j - logical :: all, lima - character :: x - character, dimension(0:10) :: orb + integer :: i, lmax, nmaks, mshell, lmaks, j + logical :: all, lima + character :: x + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - nmaks = 1 - lmaks = 0 - do i = 1, 15 - do j = 0, min(10,i - 1) - if (.not.med(i,j)) cycle - nmaks = i - lmaks = max(j,lmaks) - end do - end do - 60 continue - if (nmaks <= 9) then - write (*, 201) 'Highest n-number? (', nmaks, '..15)' - else - write (*, 202) 'Highest n-number? (', nmaks, '..15)' - endif - read (*, *, err=60) nmax - nmax = max(nmax,nmaks) - nmax = min(nmax,15) - write (logfil, *) nmax, ' Highest principal quantum number.' + 'n'/ + nmaks = 1 + lmaks = 0 + do i = 1, 15 + do j = 0, min(10,i - 1) + if (.not.med(i,j)) cycle + nmaks = i + lmaks = max(j,lmaks) + end do + end do + 60 continue + if (nmaks <= 9) then + write (*, 201) 'Highest n-number? (', nmaks, '..15)' + else + write (*, 202) 'Highest n-number? (', nmaks, '..15)' + endif + read (*, *, err=60) nmax + nmax = max(nmax,nmaks) + nmax = min(nmax,15) + write (logfil, *) nmax, ' Highest principal quantum number.' write (*, 400) 'Highest l-number? (', orb(lmaks), '..', orb(min(10,nmax-1& - )), ')' - read (*, 1000) x - lmax = -1 - do i = 0, min(10,nmax - 1) - if (x /= orb(i)) cycle - lmax = i - end do - lmax = max(lmaks,lmax) + )), ')' + read (*, 1000) x + lmax = -1 + do i = 0, min(10,nmax - 1) + if (x /= orb(i)) cycle + lmax = i + end do + lmax = max(lmaks,lmax) ! if (lmax.EQ.-1) goto 70 - write (logfil, *) lmax, ' Highest orbital angular momentum.' - write (*, 200) 'Are all these nl-subshells active? (n/*)' - read (*, 1000) x - all = .not.(x=='n' .or. x=='N') - write (logfil, *) all, ' all subshells active.' - lim = 0 - if (nmax >= 2) then + write (logfil, *) lmax, ' Highest orbital angular momentum.' + write (*, 200) 'Are all these nl-subshells active? (n/*)' + read (*, 1000) x + all = .not.(x=='n' .or. x=='N') + write (logfil, *) all, ' all subshells active.' + lim = 0 + if (nmax >= 2) then !******************* modified by yu zou, 3/6/00 ! this option cannot run correctly. It is not provided at present. - lima = .FALSE. + lima = .FALSE. !******************* modified by yu zou, 3/6/00 - write (logfil, *) lima, ' limitations on population of n-subshells.' - if (lima) then - mshell = 0 - do i = 1, nmax - 1 - mshell = mshell + 2*i*i - 83 continue - if (i == 1) then - write (*, 200) 'Minimum number of electrons with n=1? (0..2)' - else if (i < 10) then - if (mshell < 100) then + write (logfil, *) lima, ' limitations on population of n-subshells.' + if (lima) then + mshell = 0 + do i = 1, nmax - 1 + mshell = mshell + 2*i*i + 83 continue + if (i == 1) then + write (*, 200) 'Minimum number of electrons with n=1? (0..2)' + else if (i < 10) then + if (mshell < 100) then write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..', mshell, ')' - else + '? (0..', mshell, ')' + else write (*, 208) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - else + '? (0..)' + endif + else write (*, 202) 'Minimum number of electrons with n<=', i, & - '? (0..)' - endif - read (*, *, err=83) lim(i) - lim(i) = min0(mshell,lim(i)) + '? (0..)' + endif + read (*, *, err=83) lim(i) + lim(i) = min0(mshell,lim(i)) write (logfil, *) lim(i), & - ' is minimum number of electrons with n =', i - end do - endif - endif - if (all) then - do i = 1, 15 - if (i < 10) then - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - lock(i,j) = .FALSE. - else - lock(i,j) = .TRUE. + ' is minimum number of electrons with n =', i + end do + endif + endif + if (all) then + do i = 1, 15 + if (i < 10) then + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + lock(i,j) = .FALSE. + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 204) i, orb(j), & - ' is a closed shell.' - endif - end do - else - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - lock(i,j) = .FALSE. - else - lock(i,j) = .TRUE. + ' is a closed shell.' + endif + end do + else + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + lock(i,j) = .FALSE. + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 205) i, orb(j), & - ' is a closed shell.' - endif - end do - endif - end do - else - do i = 1, 15 - if (i < 10) then - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - write (*, 204) i, orb(j), ' inactive or active? ', '(i/*)' - read (*, 1000) x + ' is a closed shell.' + endif + end do + endif + end do + else + do i = 1, 15 + if (i < 10) then + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + write (*, 204) i, orb(j), ' inactive or active? ', '(i/*)' + read (*, 1000) x write (logfil, *) x, i, orb(j), & - ' inactive, active, etc...' - lock(i,j) = x=='i' .or. x=='I' - else - lock(i,j) = .TRUE. + ' inactive, active, etc...' + lock(i,j) = x=='i' .or. x=='I' + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 204) i, orb(j), & - ' is a closed shell.' - endif - end do - else - do j = 0, min(10,i - 1) - if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then - write (*, 205) i, orb(j), ' inactive or active? ', '(i/*)' - read (*, 1000) x + ' is a closed shell.' + endif + end do + else + do j = 0, min(10,i - 1) + if (nmax>=i .and. lmax>=j .and. .not.closed(i,j)) then + write (*, 205) i, orb(j), ' inactive or active? ', '(i/*)' + read (*, 1000) x write (logfil, *) x, i, orb(j), & - ' inactive, active, etc...' - lock(i,j) = x=='i' .or. x=='I' - else - lock(i,j) = .TRUE. + ' inactive, active, etc...' + lock(i,j) = x=='i' .or. x=='I' + else + lock(i,j) = .TRUE. if (closed(i,j)) write (*, 205) i, orb(j), & - ' is a closed shell.' - endif - end do - endif - end do - endif - 1100 continue + ' is a closed shell.' + endif + end do + endif + end do + endif + 1100 continue write (*, 400) 'Resulting 2*J-number? lower, higher ', & - '(J=1 -> 2*J=2 etc.)' - read (*, *, err=1100) minj, maxj - write (logfil, *) minj, ' to', maxj, ' is the resulting term.' - 160 continue - write (*, 200) 'Number of excitations = ? (0..)' - read (*, *, err=160) varmax - write (logfil, *) varmax, ' number of excitations.' - 170 continue + '(J=1 -> 2*J=2 etc.)' + read (*, *, err=1100) minj, maxj + write (logfil, *) minj, ' to', maxj, ' is the resulting term.' + 160 continue + write (*, 200) 'Number of excitations = ? (0..)' + read (*, *, err=160) varmax + write (logfil, *) varmax, ' number of excitations.' + 170 continue write (*, 400) 'Maximum number of uncoupled configuration', & - ' states? (0..)' - read (*, *, err=170) cfmax - write (logfil, *) cfmax, ' maximum number ' - write (*, *) - - 200 format(' ',a,i1,a,a,i1,a) - 201 format(' ',a,i1,a,a,i2,a) - 202 format(' ',a,i2,a,a,i1,a) - 203 format(' ',a,i2,a,a,i2,a) - 204 format(' ',i1,3a) - 205 format(' ',i2,3a) - 208 format(' ',a,i1,a,i2,a) - 300 format(' ',a,i1,a) - 301 format(' ',a,i2,a) - 400 format(' ',7a) - 401 format(' ',2a,i1,a) - 402 format(' ',2a,i2,a) - 1000 format(a,a,a) - 2000 format(i1,a) - return - end subroutine matcin + ' states? (0..)' + read (*, *, err=170) cfmax + write (logfil, *) cfmax, ' maximum number ' + write (*, *) + + 200 format(' ',a,i1,a,a,i1,a) + 201 format(' ',a,i1,a,a,i2,a) + 202 format(' ',a,i2,a,a,i1,a) + 203 format(' ',a,i2,a,a,i2,a) + 204 format(' ',i1,3a) + 205 format(' ',i2,3a) + 208 format(' ',a,i1,a,i2,a) + 300 format(' ',a,i1,a) + 301 format(' ',a,i2,a) + 400 format(' ',7a) + 401 format(' ',2a,i1,a) + 402 format(' ',2a,i2,a) + 1000 format(a,a,a) + 2000 format(i1,a) + return + end subroutine matcin diff --git a/src/appl/rcsfgenerate90/matcin_I.f90 b/src/appl/rcsfgenerate90/matcin_I.f90 index 4527e2574..089866552 100644 --- a/src/appl/rcsfgenerate90/matcin_I.f90 +++ b/src/appl/rcsfgenerate90/matcin_I.f90 @@ -1,18 +1,18 @@ - MODULE matcin_I + MODULE matcin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE matcin (LOCK, CLOSED, MED, VARMAX, CFMAX, NMAX, MINJ, MAXJ& - , LIM) - logical, DIMENSION(15,0:10), INTENT(OUT) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED - logical, DIMENSION(15,0:10), INTENT(IN) :: MED - integer, INTENT(IN) :: VARMAX - integer, INTENT(IN) :: CFMAX - integer, INTENT(OUT) :: NMAX - integer, INTENT(IN) :: MINJ - integer, INTENT(IN) :: MAXJ - integer, DIMENSION(15), INTENT(INOUT) :: LIM + , LIM) + logical, DIMENSION(15,0:10), INTENT(OUT) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: CLOSED + logical, DIMENSION(15,0:10), INTENT(IN) :: MED + integer, INTENT(IN) :: VARMAX + integer, INTENT(IN) :: CFMAX + integer, INTENT(OUT) :: NMAX + integer, INTENT(IN) :: MINJ + integer, INTENT(IN) :: MAXJ + integer, DIMENSION(15), INTENT(INOUT) :: LIM !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/merge.f90 b/src/appl/rcsfgenerate90/merge.f90 index 8dd555e80..4300db09f 100644 --- a/src/appl/rcsfgenerate90/merge.f90 +++ b/src/appl/rcsfgenerate90/merge.f90 @@ -1,176 +1,176 @@ ! last edited July 31, 1996 - subroutine merge(single, posn, posl, ii) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine merge(single, posn, posl, ii) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use lika_I - use fivefirst_I - use lasa1_I - use test_I - use lasa2_I + use lika_I + use fivefirst_I + use lasa1_I + use test_I + use lasa2_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: ii - logical , intent(in) :: single - integer :: posn(110) - integer :: posl(110) + integer , intent(in) :: ii + logical , intent(in) :: single + integer :: posn(110) + integer :: posl(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: fil_2 = 8 - integer, parameter :: utfil = 9 - integer, parameter :: nyfil = 13 + integer, parameter :: fil_1 = 7 + integer, parameter :: fil_2 = 8 + integer, parameter :: utfil = 9 + integer, parameter :: nyfil = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop1, pop2 - integer :: skal1, skal2, i, j, k, cf, stopp1, stopp2 - integer , dimension(15,0:10,0:1) :: popo - integer :: ii1 - logical :: p1, p2, slut1, slut2 + integer , dimension(15,0:10,0:1) :: pop1, pop2 + integer :: skal1, skal2, i, j, k, cf, stopp1, stopp2 + integer , dimension(15,0:10,0:1) :: popo + integer :: ii1 + logical :: p1, p2, slut1, slut2 character :: rad11*200, rad12*200, rad21*200, rad22*200, rad31*200, rad32& - *200 + *200 !----------------------------------------------- - ii1 = mod(ii,2) - if (ii1 == 0) then - open(unit=utfil, file='rcsf.out', status='unknown', position='asis') - else - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - endif - open(unit=nyfil, file='clist.new', status='unknown', position='asis') - slut1 = .FALSE. - slut2 = single - cf = 0 - call fivefirst (slut1, slut2, posn, posl) - skal1 = 20 - skal2 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - 10 continue - if (.not.slut1 .and. .not.slut2) then - call test (p1, p2, pop1, pop2, 15) - if (p1) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) - end do - stopp1 = max(1,9*skal1) - stopp2 = 9*skal1 + 2 - 30 continue - call lasa2 (fil_1, rad21, rad31, stopp1, slut1) - if (.not.slut1) then - write (utfil, 999) rad11(1:stopp1) - write (utfil, 999) rad21(1:stopp1) - write (utfil, 999) rad31(1:stopp2) - cf = cf + 1 - endif - skal1 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - if (.not.slut1) then - if (lika(popo,pop1)) go to 30 - endif - if (p2) then - 40 continue - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) then - if (lika(popo,pop2)) go to 40 - endif - endif - go to 10 - else if (p2) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) - end do - stopp1 = max(1,9*skal2) - stopp2 = 9*skal2 + 2 - 60 continue - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - if (.not.slut2) then - write (utfil, 999) rad12(1:stopp1) - write (utfil, 999) rad22(1:stopp1) - write (utfil, 999) rad32(1:stopp2) - write (nyfil, 999) rad12(1:stopp1) - write (nyfil, 999) rad22(1:stopp1) - write (nyfil, 999) rad32(1:stopp2) - cf = cf + 1 - endif - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) then - if (lika(popo,pop2)) go to 60 - endif - go to 10 - else - write (*, *) 'fatal error' - stop - endif - else if (.not.slut1 .and. slut2) then - 70 continue - stopp1 = max(1,9*skal1) - stopp2 = 9*skal1 + 2 - call lasa2 (fil_1, rad21, rad31, stopp1, slut1) - if (.not.slut1) then - write (utfil, 999) rad11(1:stopp1) - write (utfil, 999) rad21(1:stopp1) - write (utfil, 999) rad31(1:stopp2) - cf = cf + 1 - endif - skal1 = 20 - call lasa1 (fil_1, rad11, pop1, skal1, slut1) - if (.not.slut1) go to 70 - else if (slut1 .and. .not.slut2) then - 80 continue - stopp1 = max(1,9*skal2) - stopp2 = 9*skal2 + 2 - call lasa2 (fil_2, rad22, rad32, stopp1, slut2) - if (.not.slut2) then - write (utfil, 999) rad12(1:stopp1) - write (utfil, 999) rad22(1:stopp1) - write (utfil, 999) rad32(1:stopp2) - write (nyfil, 999) rad12(1:stopp1) - write (nyfil, 999) rad22(1:stopp1) - write (nyfil, 999) rad32(1:stopp2) - cf = cf + 1 - endif - skal2 = 20 - call lasa1 (fil_2, rad12, pop2, skal2, slut2) - if (.not.slut2) go to 80 - endif - close(fil_1) - close(fil_2) - close(utfil) - close(nyfil) - if (cf == 0) then - write (*, 105) 'No configuration state in the final list.' - else if (cf == 1) then - write (*, 105) 'One configuration state in the final list.' - else if (cf < 10) then - write (*, 101) cf, ' configuration states in the final list.' - else if (cf < 100) then - write (*, 102) cf, ' configuration states in the final list.' - else if (cf < 1000) then - write (*, 103) cf, ' configuration states in the final list.' - else if (cf < 10000) then - write (*, 104) cf, ' configuration states in the final list.' - else if (cf < 100000) then - write (*, 106) cf, ' configuration states in the final list.' - else - write (*, *) cf, ' configuration states in the final list.' - endif - return - 101 format(' ',i1,a) - 102 format(' ',i2,a) - 103 format(' ',i3,a) - 104 format(' ',i4,a) - 105 format(' ',a) - 106 format(' ',i5,a) - 999 format(a) - return - end subroutine merge + ii1 = mod(ii,2) + if (ii1 == 0) then + open(unit=utfil, file='rcsf.out', status='unknown', position='asis') + else + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + endif + open(unit=nyfil, file='clist.new', status='unknown', position='asis') + slut1 = .FALSE. + slut2 = single + cf = 0 + call fivefirst (slut1, slut2, posn, posl) + skal1 = 20 + skal2 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + 10 continue + if (.not.slut1 .and. .not.slut2) then + call test (p1, p2, pop1, pop2, 15) + if (p1) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) + end do + stopp1 = max(1,9*skal1) + stopp2 = 9*skal1 + 2 + 30 continue + call lasa2 (fil_1, rad21, rad31, stopp1, slut1) + if (.not.slut1) then + write (utfil, 999) rad11(1:stopp1) + write (utfil, 999) rad21(1:stopp1) + write (utfil, 999) rad31(1:stopp2) + cf = cf + 1 + endif + skal1 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + if (.not.slut1) then + if (lika(popo,pop1)) go to 30 + endif + if (p2) then + 40 continue + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) then + if (lika(popo,pop2)) go to 40 + endif + endif + go to 10 + else if (p2) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) + end do + stopp1 = max(1,9*skal2) + stopp2 = 9*skal2 + 2 + 60 continue + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + if (.not.slut2) then + write (utfil, 999) rad12(1:stopp1) + write (utfil, 999) rad22(1:stopp1) + write (utfil, 999) rad32(1:stopp2) + write (nyfil, 999) rad12(1:stopp1) + write (nyfil, 999) rad22(1:stopp1) + write (nyfil, 999) rad32(1:stopp2) + cf = cf + 1 + endif + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) then + if (lika(popo,pop2)) go to 60 + endif + go to 10 + else + write (*, *) 'fatal error' + stop + endif + else if (.not.slut1 .and. slut2) then + 70 continue + stopp1 = max(1,9*skal1) + stopp2 = 9*skal1 + 2 + call lasa2 (fil_1, rad21, rad31, stopp1, slut1) + if (.not.slut1) then + write (utfil, 999) rad11(1:stopp1) + write (utfil, 999) rad21(1:stopp1) + write (utfil, 999) rad31(1:stopp2) + cf = cf + 1 + endif + skal1 = 20 + call lasa1 (fil_1, rad11, pop1, skal1, slut1) + if (.not.slut1) go to 70 + else if (slut1 .and. .not.slut2) then + 80 continue + stopp1 = max(1,9*skal2) + stopp2 = 9*skal2 + 2 + call lasa2 (fil_2, rad22, rad32, stopp1, slut2) + if (.not.slut2) then + write (utfil, 999) rad12(1:stopp1) + write (utfil, 999) rad22(1:stopp1) + write (utfil, 999) rad32(1:stopp2) + write (nyfil, 999) rad12(1:stopp1) + write (nyfil, 999) rad22(1:stopp1) + write (nyfil, 999) rad32(1:stopp2) + cf = cf + 1 + endif + skal2 = 20 + call lasa1 (fil_2, rad12, pop2, skal2, slut2) + if (.not.slut2) go to 80 + endif + close(fil_1) + close(fil_2) + close(utfil) + close(nyfil) + if (cf == 0) then + write (*, 105) 'No configuration state in the final list.' + else if (cf == 1) then + write (*, 105) 'One configuration state in the final list.' + else if (cf < 10) then + write (*, 101) cf, ' configuration states in the final list.' + else if (cf < 100) then + write (*, 102) cf, ' configuration states in the final list.' + else if (cf < 1000) then + write (*, 103) cf, ' configuration states in the final list.' + else if (cf < 10000) then + write (*, 104) cf, ' configuration states in the final list.' + else if (cf < 100000) then + write (*, 106) cf, ' configuration states in the final list.' + else + write (*, *) cf, ' configuration states in the final list.' + endif + return + 101 format(' ',i1,a) + 102 format(' ',i2,a) + 103 format(' ',i3,a) + 104 format(' ',i4,a) + 105 format(' ',a) + 106 format(' ',i5,a) + 999 format(a) + return + end subroutine merge diff --git a/src/appl/rcsfgenerate90/merge_I.f90 b/src/appl/rcsfgenerate90/merge_I.f90 index 9b5dcfa0f..d5599f84d 100644 --- a/src/appl/rcsfgenerate90/merge_I.f90 +++ b/src/appl/rcsfgenerate90/merge_I.f90 @@ -1,11 +1,11 @@ - MODULE merge_I + MODULE merge_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE merge (SINGLE, POSN, POSL, II) - logical, INTENT(IN) :: SINGLE - integer, DIMENSION(110) :: POSN - integer, DIMENSION(110) :: POSL - integer, INTENT(IN) :: II - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE merge (SINGLE, POSN, POSL, II) + logical, INTENT(IN) :: SINGLE + integer, DIMENSION(110) :: POSN + integer, DIMENSION(110) :: POSL + integer, INTENT(IN) :: II + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/mergeb.f90 b/src/appl/rcsfgenerate90/mergeb.f90 index e82174593..fe038bc30 100644 --- a/src/appl/rcsfgenerate90/mergeb.f90 +++ b/src/appl/rcsfgenerate90/mergeb.f90 @@ -1,139 +1,139 @@ ! last edited July 31, 1996 - subroutine mergeb(antal) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine mergeb(antal) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use test_I + use test_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(out) :: antal + integer , intent(out) :: antal !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10,0:1) :: pop1, pop2, popo - integer :: i, j, k - logical :: p1, p2, slut1, slut2 + integer , dimension(15,0:10,0:1) :: pop1, pop2, popo + integer :: i, j, k + logical :: p1, p2, slut1, slut2 !----------------------------------------------- - slut1 = .FALSE. - slut2 = .FALSE. - antal = 0 - open(unit=22, status='scratch', position='asis') - do i = 1, 15 - read (20, 5000, end=2) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=2) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 3 - 2 continue - slut1 = .TRUE. - 3 continue - do i = 1, 15 - read (21, 5000, end=5) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=5) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 6 - 5 continue - slut2 = .TRUE. - 6 continue - 10 continue - if (.not.slut1 .and. .not.slut2) then - call test (p1, p2, pop1, pop2, 15) - if (p1) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) - end do - do i = 1, 15 - write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (20, 5000, end=21) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=21) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 22 - 21 continue - slut1 = .TRUE. - 22 continue - if (p2) then - do i = 1, 15 - read (21, 5000, end=23) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=23) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 10 - 23 continue - slut2 = .TRUE. - endif - else if (p2) then - do i = 1, 15 - popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) - end do - if (.not.slut2) then - do i = 1, 15 - write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - endif - do i = 1, 15 - read (21, 5000, end=53) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=53) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 10 - 53 continue - slut2 = .TRUE. - else - write (*, *) 'fatal error' - stop - endif - go to 10 - else if (.not.slut1 .and. slut2) then - 70 continue - do i = 1, 15 - write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (20, 5000, end=71) (pop1(i,j,0),j=0,min(10,i - 1)) - read (20, 5000, end=71) (pop1(i,j,1),j=0,min(10,i - 1)) - end do - go to 70 - 71 continue - slut1 = .TRUE. - else if (slut1 .and. .not.slut2) then - 80 continue - do i = 1, 15 - write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - read (21, 5000, end=81) (pop2(i,j,0),j=0,min(10,i - 1)) - read (21, 5000, end=81) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - go to 80 - 81 continue - slut2 = .TRUE. - endif - rewind (22) - close(20) - close(21) - open(unit=20, status='scratch', position='asis') - 580 continue - do i = 1, 15 - read (22, 5000, end=999) (pop2(i,j,0),j=0,min(10,i - 1)) - read (22, 5000, end=999) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - do i = 1, 15 - write (20, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) - write (20, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) - end do - antal = antal + 1 - go to 580 - 999 continue - close(22) - rewind (20) - return - 5000 format(11i2) - return - end subroutine mergeb + slut1 = .FALSE. + slut2 = .FALSE. + antal = 0 + open(unit=22, status='scratch', position='asis') + do i = 1, 15 + read (20, 5000, end=2) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=2) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 3 + 2 continue + slut1 = .TRUE. + 3 continue + do i = 1, 15 + read (21, 5000, end=5) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=5) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 6 + 5 continue + slut2 = .TRUE. + 6 continue + 10 continue + if (.not.slut1 .and. .not.slut2) then + call test (p1, p2, pop1, pop2, 15) + if (p1) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop1(i,:min(10,i-1),:1) + end do + do i = 1, 15 + write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (20, 5000, end=21) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=21) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 22 + 21 continue + slut1 = .TRUE. + 22 continue + if (p2) then + do i = 1, 15 + read (21, 5000, end=23) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=23) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 10 + 23 continue + slut2 = .TRUE. + endif + else if (p2) then + do i = 1, 15 + popo(i,:min(10,i-1),:1) = pop2(i,:min(10,i-1),:1) + end do + if (.not.slut2) then + do i = 1, 15 + write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + endif + do i = 1, 15 + read (21, 5000, end=53) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=53) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 10 + 53 continue + slut2 = .TRUE. + else + write (*, *) 'fatal error' + stop + endif + go to 10 + else if (.not.slut1 .and. slut2) then + 70 continue + do i = 1, 15 + write (22, 5000) (pop1(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (20, 5000, end=71) (pop1(i,j,0),j=0,min(10,i - 1)) + read (20, 5000, end=71) (pop1(i,j,1),j=0,min(10,i - 1)) + end do + go to 70 + 71 continue + slut1 = .TRUE. + else if (slut1 .and. .not.slut2) then + 80 continue + do i = 1, 15 + write (22, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (22, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + read (21, 5000, end=81) (pop2(i,j,0),j=0,min(10,i - 1)) + read (21, 5000, end=81) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + go to 80 + 81 continue + slut2 = .TRUE. + endif + rewind (22) + close(20) + close(21) + open(unit=20, status='scratch', position='asis') + 580 continue + do i = 1, 15 + read (22, 5000, end=999) (pop2(i,j,0),j=0,min(10,i - 1)) + read (22, 5000, end=999) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + do i = 1, 15 + write (20, 5000) (pop2(i,j,0),j=0,min(10,i - 1)) + write (20, 5000) (pop2(i,j,1),j=0,min(10,i - 1)) + end do + antal = antal + 1 + go to 580 + 999 continue + close(22) + rewind (20) + return + 5000 format(11i2) + return + end subroutine mergeb diff --git a/src/appl/rcsfgenerate90/mergeb_I.f90 b/src/appl/rcsfgenerate90/mergeb_I.f90 index 1a2b19353..d756de55d 100644 --- a/src/appl/rcsfgenerate90/mergeb_I.f90 +++ b/src/appl/rcsfgenerate90/mergeb_I.f90 @@ -1,8 +1,8 @@ - MODULE mergeb_I + MODULE mergeb_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE mergeb (ANTAL) - integer, INTENT(OUT) :: ANTAL - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE mergeb (ANTAL) + integer, INTENT(OUT) :: ANTAL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/open79.f90 b/src/appl/rcsfgenerate90/open79.f90 index f7036401a..d9eafa95f 100644 --- a/src/appl/rcsfgenerate90/open79.f90 +++ b/src/appl/rcsfgenerate90/open79.f90 @@ -1,31 +1,30 @@ - subroutine open79(i) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine open79(i) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i + integer , intent(in) :: i !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: fil_1 = 7 - integer, parameter :: utfil = 9 + integer, parameter :: fil_1 = 7 + integer, parameter :: utfil = 9 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i1 + integer :: i1 !----------------------------------------------- - i1 = mod(i,2) - if (i1 == 0) then - open(fil_1, file='fil1.dat', status='unknown', position='asis') - open(unit=utfil, file='rcsf.out', status='unknown', position='asis') - else - open(fil_1, file='rcsf.out', status='unknown', position='asis') - open(unit=utfil, file='fil1.dat', status='unknown', position='asis') - endif - close(utfil) - rewind (fil_1) - return - end subroutine open79 - + i1 = mod(i,2) + if (i1 == 0) then + open(fil_1, file='fil1.dat', status='unknown', position='asis') + open(unit=utfil, file='rcsf.out', status='unknown', position='asis') + else + open(fil_1, file='rcsf.out', status='unknown', position='asis') + open(unit=utfil, file='fil1.dat', status='unknown', position='asis') + endif + close(utfil) + rewind (fil_1) + return + end subroutine open79 diff --git a/src/appl/rcsfgenerate90/open79_I.f90 b/src/appl/rcsfgenerate90/open79_I.f90 index 564bee571..25852059f 100644 --- a/src/appl/rcsfgenerate90/open79_I.f90 +++ b/src/appl/rcsfgenerate90/open79_I.f90 @@ -1,9 +1,9 @@ - MODULE open79_I + MODULE open79_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE open79 (I) - integer, INTENT(IN) :: I +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE open79 (I) + integer, INTENT(IN) :: I !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/rcsfblock.f90 b/src/appl/rcsfgenerate90/rcsfblock.f90 index 1b438e0b1..f7c77b075 100644 --- a/src/appl/rcsfgenerate90/rcsfblock.f90 +++ b/src/appl/rcsfgenerate90/rcsfblock.f90 @@ -239,4 +239,4 @@ SUBROUTINE indexa(n,a,ldown,indx) ENDIF RETURN END - + diff --git a/src/appl/rcsfgenerate90/rcsfexcitation.f90 b/src/appl/rcsfgenerate90/rcsfexcitation.f90 index 6328b367a..9d3974db0 100644 --- a/src/appl/rcsfgenerate90/rcsfexcitation.f90 +++ b/src/appl/rcsfgenerate90/rcsfexcitation.f90 @@ -50,21 +50,21 @@ subroutine rcsfexcitation !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -write(*,*) +write(*,*) write(*,*) 'RCSFGENERATE' write(*,*) 'This program generates a list of CSFs' -write(*,*) +write(*,*) write(*,*) 'Configurations should be entered in spectroscopic notation' write(*,*) 'with occupation numbers and indications if orbitals are' write(*,*) 'closed (c), inactive (i), active (*) or has a minimal' write(*,*) 'occupation e.g. 1s(2,1)2s(2,*)' write(*,*) 'Outputfiles: rcsf.out, rcsfgenerate.log' -write(*,*) +write(*,*) write(*,*) 'Default, reverse, symmetry or user specified ordering? (*/r/s/u)' read(*,*) ans write(11,'(a)') ans write(12,*) ans, ' ! Orbital order' -write(*,*) +write(*,*) write(*,*) 'Select core ' write(*,*) ' 0: No core' write(*,*) ' 1: He ( 1s(2) = 2 electrons)' @@ -77,9 +77,9 @@ subroutine rcsfexcitation write(12,*) ncore, ' ! Selected core' ! Due to restrictions in the underlying jjgen we have do use the following "trick" -! if ncore == 5 then we redefine the core to ncore = 4 and add +! if ncore == 5 then we redefine the core to ncore = 4 and add ! 4d(10,c)5s(2,c)5p(6,c) to each of the configuration strings -! if ncore == 6 then we redefine the core to ncore = 5 and add +! if ncore == 6 then we redefine the core to ncore = 5 and add ! 4f(14,c)5d(10,c)6s(2,c)6p(6,c) to each of the configuration strings ! Per J Feb 2017 @@ -107,12 +107,12 @@ subroutine rcsfexcitation select case(ncore) case(1) ncoreorbitals = 1 ! 1 core orbital - lmaxcore = 0 ! + lmaxcore = 0 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s case(2) ncoreorbitals = 3 ! 3 core orbitals - lmaxcore = 1 ! + lmaxcore = 1 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s nc(2) = 2 ! 2s @@ -121,7 +121,7 @@ subroutine rcsfexcitation lc(3) = 1 ! 2p case(3) ncoreorbitals = 5 ! 5 core orbitals - lmaxcore = 1 ! + lmaxcore = 1 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s nc(2) = 2 ! 2s @@ -134,7 +134,7 @@ subroutine rcsfexcitation lc(5) = 1 ! 3p case(4) ncoreorbitals = 8 ! 8 core orbitals - lmaxcore = 2 ! + lmaxcore = 2 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s nc(2) = 2 ! 2s @@ -153,7 +153,7 @@ subroutine rcsfexcitation lc(8) = 1 ! 4p case(5) ncoreorbitals = 11 ! 11 core orbitals - lmaxcore = 2 ! + lmaxcore = 2 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s nc(2) = 2 ! 2s @@ -178,7 +178,7 @@ subroutine rcsfexcitation lc(11) = 1 ! 5p case(6) ncoreorbitals = 15 ! 15 core orbitals - lmaxcore = 3 ! + lmaxcore = 3 ! nc(1) = 1 ! 1s lc(1) = 0 ! 1s nc(2) = 2 ! 2s @@ -222,7 +222,7 @@ subroutine rcsfexcitation ! Input the mutireference for later processing write(*,*) 'Enter list of (maximum 100) configurations. End list with a blank line or an asterisk (*)' -write(*,*) +write(*,*) do j = 1,100 @@ -233,7 +233,7 @@ subroutine rcsfexcitation mr = j-1 write(12,'(a)') '*' goto 99 - end if + end if ! Initial check, each orbital need to be closed, inactive, or minimal @@ -241,8 +241,8 @@ subroutine rcsfexcitation number1 = 0 number2 = 0 do k = 1,conflength - if (configvect(j)(k:k).eq.'(') number1 = number1 + 1 - if (configvect(j)(k:k).eq.',') number2 = number2 + 1 + if (configvect(j)(k:k).eq.'(') number1 = number1 + 1 + if (configvect(j)(k:k).eq.',') number2 = number2 + 1 end do if (number1.ne.number2) then write(*,*) 'Each orbital must be closed (c), inactive (i), active (*)' @@ -251,7 +251,7 @@ subroutine rcsfexcitation end if write(12,'(a)') trim(configvect(j)) -! Here we append string if we have redefined core Per J Feb 2017 +! Here we append string if we have redefined core Per J Feb 2017 if (ncore5to4.eq.1) then configvect(j) = trim(corestring5//configvect(j)) @@ -306,7 +306,7 @@ subroutine rcsfexcitation nfoundf = 1 end if end do - if (nfoundf.eq.0) then + if (nfoundf.eq.0) then ! Did not find f. Insert 3f either after d symmetry or before g symmetry nfoundd = 0 do i = 1,len_trim(orbitalstring) @@ -316,17 +316,17 @@ subroutine rcsfexcitation orbitalstring = orbitalstring(1:i)//',3f'//orbitalstring(i+1:len_trim(orbitalstring)) else orbitalstring = orbitalstring(1:i)//',3f' - end if + end if exit end if end do - if (nfoundd.eq.0) then + if (nfoundd.eq.0) then orbitalstring = '3f,'//trim(orbitalstring) end if end if ! write(*,'(a)') trim(orbitalstring) ! pause -end if +end if ! De-code orbital string @@ -344,7 +344,7 @@ subroutine rcsfexcitation orbital(k) = " " // orbitalstring(jl:jr-1) else write(*,*) 'Orbitals should be given in comma delimited list, redo!' - goto 99 + goto 99 end if jl = jr + 1 k = k +1 @@ -357,9 +357,9 @@ subroutine rcsfexcitation orbital(k) = " " // orbitalstring(jl:jr) else write(*,*) 'Orbitals should be given in comma delimited list, redo!' - goto 99 + goto 99 end if -write(12,'(a)') trim(orbitalstring) +write(12,'(a)') trim(orbitalstring) norbstrings = k @@ -513,7 +513,7 @@ subroutine rcsfexcitation flag(:) = 0 do k = 1,norb i = 1+orbstart(k-1) - if(config(i+4:i+4).eq.',') flag(k) = 1 ! Flag to facilitate determination if + if(config(i+4:i+4).eq.',') flag(k) = 1 ! Flag to facilitate determination if ! occupation/type indicator occupies one/two positions select case(config(i:i)) case('1') @@ -650,7 +650,7 @@ subroutine rcsfexcitation else write(11,'(a)') 'c' write(11,*) ncore - end if + end if end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -692,12 +692,12 @@ subroutine rcsfexcitation end do if (nclose.eq.1) cycle -! Find out if orbital is closed then add it to core orbitals +! Find out if orbital is closed then add it to core orbitals ! In for the next reference configuration there will be no question for this do k = 1, norb if ((nr.eq.n(k)).and.(lr.eq.l(k))) then - if (trim(adjustl(sel(k))).eq.'c') then + if (trim(adjustl(sel(k))).eq.'c') then ncoreorbitals = ncoreorbitals + 1 nc(ncoreorbitals) = n(k) lc(ncoreorbitals) = l(k) @@ -723,7 +723,7 @@ subroutine rcsfexcitation if (ndouble.eq.1) then write(11,'(a)') 'd' else - write(11,'(a)') '*' + write(11,'(a)') '*' end if else write(11,'(a)') 'i' @@ -741,7 +741,7 @@ subroutine rcsfexcitation do lr = 0,min(nr-1,lmax) if (nr.le.nl(lr)) then if (ndouble.eq.1) then - write(11,'(a)') 'd' + write(11,'(a)') 'd' else write(11,'(a)') '*' end if @@ -777,5 +777,3 @@ subroutine rcsfexcitation close(11) end subroutine rcsfexcitation - - diff --git a/src/appl/rcsfgenerate90/reada.f90 b/src/appl/rcsfgenerate90/reada.f90 index 6ec3bc655..fab00ecfd 100644 --- a/src/appl/rcsfgenerate90/reada.f90 +++ b/src/appl/rcsfgenerate90/reada.f90 @@ -1,75 +1,75 @@ ! last edited July 31, 1996 - subroutine reada(rad1, pop, skal, slut) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reada(rad1, pop, skal, slut) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: skal - logical , intent(out) :: slut - character , intent(in) :: rad1*200 - integer , intent(out) :: pop(15,0:10,0:1) + integer , intent(inout) :: skal + logical , intent(out) :: slut + character , intent(in) :: rad1*200 + integer , intent(out) :: pop(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, j, k, n, l, antal, stopp - character, dimension(0:10) :: orb + integer :: i, j, k, n, l, antal, stopp + character, dimension(0:10) :: orb !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ - slut = .FALSE. - do n = 1, 15 - pop(n,:min(10,n-1),:1) = 0 - end do - stopp = skal - 1 - l10: do i = 0, stopp - j = 9*i - if (rad1(j+3:j+3) == ' ') return - skal = i + 1 - slut = .TRUE. - n = ichar(rad1(j+3:j+3)) - ichar('0') - if (rad1(j+2:j+2) == '1') n = n + 10 - if (n<=15 .and. n>=1) then - if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 0 - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - else - do l = 0, min(10,n - 1) - if (rad1(j+4:j+4) /= orb(l)) cycle - slut = .FALSE. - antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) - antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') - if (antal > 4*l + 2) then - slut = .TRUE. - return - endif - if (rad1(j+5:j+5)=='-' .or. l==0) then - pop(n,l,0) = antal - else - pop(n,l,1) = antal - endif - cycle l10 - end do - endif - else - slut = .TRUE. - return - endif - end do l10 - return - end subroutine reada + 'n'/ + slut = .FALSE. + do n = 1, 15 + pop(n,:min(10,n-1),:1) = 0 + end do + stopp = skal - 1 + l10: do i = 0, stopp + j = 9*i + if (rad1(j+3:j+3) == ' ') return + skal = i + 1 + slut = .TRUE. + n = ichar(rad1(j+3:j+3)) - ichar('0') + if (rad1(j+2:j+2) == '1') n = n + 10 + if (n<=15 .and. n>=1) then + if (rad1(j+7:j+7)==' ' .or. rad1(j+7:j+7)=='0') then + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 0 + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + else + do l = 0, min(10,n - 1) + if (rad1(j+4:j+4) /= orb(l)) cycle + slut = .FALSE. + antal = 10*(ichar(rad1(j+7:j+7))-ichar('0')) + antal = antal + ichar(rad1(j+8:j+8)) - ichar('0') + if (antal > 4*l + 2) then + slut = .TRUE. + return + endif + if (rad1(j+5:j+5)=='-' .or. l==0) then + pop(n,l,0) = antal + else + pop(n,l,1) = antal + endif + cycle l10 + end do + endif + else + slut = .TRUE. + return + endif + end do l10 + return + end subroutine reada diff --git a/src/appl/rcsfgenerate90/reada_I.f90 b/src/appl/rcsfgenerate90/reada_I.f90 index cf2b06529..c678575ac 100644 --- a/src/appl/rcsfgenerate90/reada_I.f90 +++ b/src/appl/rcsfgenerate90/reada_I.f90 @@ -1,11 +1,11 @@ - MODULE reada_I + MODULE reada_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE reada (RAD1, POP, SKAL, SLUT) - character (LEN = 200), INTENT(IN) :: RAD1 - integer, DIMENSION(15,0:10,0:1), INTENT(OUT) :: POP - integer, INTENT(INOUT) :: SKAL - logical, INTENT(OUT) :: SLUT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE reada (RAD1, POP, SKAL, SLUT) + character (LEN = 200), INTENT(IN) :: RAD1 + integer, DIMENSION(15,0:10,0:1), INTENT(OUT) :: POP + integer, INTENT(INOUT) :: SKAL + logical, INTENT(OUT) :: SLUT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/reffa.f90 b/src/appl/rcsfgenerate90/reffa.f90 index 047607772..5903a9554 100644 --- a/src/appl/rcsfgenerate90/reffa.f90 +++ b/src/appl/rcsfgenerate90/reffa.f90 @@ -1,134 +1,134 @@ ! last edited July 31, 1996 - subroutine reffa(posn, posl) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine reffa(posn, posl) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(inout) :: posn(110) - integer , intent(inout) :: posl(110) + integer , intent(inout) :: posn(110) + integer , intent(inout) :: posl(110) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - integer, parameter :: logfil = 31 - integer, parameter :: reffil = 18 + integer, parameter :: logfil = 31 + integer, parameter :: reffil = 18 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer , dimension(15,0:10) :: stat - integer :: i, n, l, num - logical :: ok - character , dimension(0:10) :: orb - character :: m, x, y + integer , dimension(15,0:10) :: stat + integer :: i, n, l, num + logical :: ok + character , dimension(0:10) :: orb + character :: m, x, y !----------------------------------------------- data (orb(i),i=0,10)/ 's', 'p', 'd', 'f', 'g', 'h', 'i', 'k', 'l', 'm', & - 'n'/ + 'n'/ !----------------------------------------------- - - do n = 1, 15 - stat(n,:min(n-1,10)) = 0 - end do + + do n = 1, 15 + stat(n,:min(n-1,10)) = 0 + end do write (*, 200) 'Default, reverse, symmetry or user specified ordering?', & - ' (*/r/s/u)' - read (193, 1000) x - if (x=='u' .or. x=='U') then - write (logfil, *) 'User specified ordering.' - inquire(file='clist.ref', exist=ok) + ' (*/r/s/u)' + read (193, 1000) x + if (x=='u' .or. x=='U') then + write (logfil, *) 'User specified ordering.' + inquire(file='clist.ref', exist=ok) if (ok) open(unit=reffil, status='old', file='clist.ref', position=& - 'asis') - l = -1 - num = 1 - if (.not.ok) then + 'asis') + l = -1 + num = 1 + if (.not.ok) then write(*,200) 'User defined orbital ordering selected but' write(*,200) 'there is no file clist.ref with orbital order' write(*,200) 'Please supply this file and rerun' stop - else - write (*, 200) 'Reference file present!' - 20 continue - read (reffil, 1000, end=40) m, x, y - n = ichar(m) - ichar('0') - if (x>='0' .and. x<='9') then - n = n*10 + ichar(x) - ichar('0') - x = y - endif - do i = 0, 10 - if (orb(i) /= x) cycle - l = i - end do - if (l==(-1) .or. n<0 .or. n>15 .or. n<=l .or. l>10) go to 40 - if (stat(n,l) /= 0) then - write (*, 200) 'The same orbital appeared more than once!' - l = -1 - go to 20 - endif - posn(num) = n - posl(num) = l - stat(n,l) = num - num = num + 1 - l = -1 - go to 20 - 40 continue - if (num == 1) then + else + write (*, 200) 'Reference file present!' + 20 continue + read (reffil, 1000, end=40) m, x, y + n = ichar(m) - ichar('0') + if (x>='0' .and. x<='9') then + n = n*10 + ichar(x) - ichar('0') + x = y + endif + do i = 0, 10 + if (orb(i) /= x) cycle + l = i + end do + if (l==(-1) .or. n<0 .or. n>15 .or. n<=l .or. l>10) go to 40 + if (stat(n,l) /= 0) then + write (*, 200) 'The same orbital appeared more than once!' + l = -1 + go to 20 + endif + posn(num) = n + posl(num) = l + stat(n,l) = num + num = num + 1 + l = -1 + go to 20 + 40 continue + if (num == 1) then write (*, 200) 'The program failed reading the order of ', & - 'the customized coupling scheme.' - else + 'the customized coupling scheme.' + else write (*, 200) 'The couplings will ', & - 'be made in the following customized order:' - if (num == 2) then - write (*, 100) posn(1), orb(posl(1)) - else + 'be made in the following customized order:' + if (num == 2) then + write (*, 100) posn(1), orb(posl(1)) + else write (*, 100) posn(1), orb(posl(1)), (',',posn(i),orb(posl(i& - )),i=2,num - 1) - endif - endif - endif - do n = 1, 15 - do l = 0, min(n - 1,10) - if (stat(n,l) /= 0) cycle - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - close(reffil) - write (*, 200) - else if (x=='s' .or. x=='S') then - write (logfil, *) 'Symmetry ordering.' - num = 1 - do l = 0, 10 - do n = l + 1, 15 - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - else if (x=='r' .or. x=='R') then - write (logfil, *) 'Reverse ordering.' - num = 1 - do n = 15, 1, -1 - do l = min(n - 1,10), 0, -1 - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - else - write (logfil, *) 'Standard ordering.' - num = 1 - do n = 1, 15 - do l = 0, min(n - 1,10) - posn(num) = n - posl(num) = l - num = num + 1 - end do - end do - endif - return - 100 format(' ',110(i2,a,a)) - 200 format(' ',2a) - 1000 format(3a) - return - end subroutine reffa + )),i=2,num - 1) + endif + endif + endif + do n = 1, 15 + do l = 0, min(n - 1,10) + if (stat(n,l) /= 0) cycle + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + close(reffil) + write (*, 200) + else if (x=='s' .or. x=='S') then + write (logfil, *) 'Symmetry ordering.' + num = 1 + do l = 0, 10 + do n = l + 1, 15 + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + else if (x=='r' .or. x=='R') then + write (logfil, *) 'Reverse ordering.' + num = 1 + do n = 15, 1, -1 + do l = min(n - 1,10), 0, -1 + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + else + write (logfil, *) 'Standard ordering.' + num = 1 + do n = 1, 15 + do l = 0, min(n - 1,10) + posn(num) = n + posl(num) = l + num = num + 1 + end do + end do + endif + return + 100 format(' ',110(i2,a,a)) + 200 format(' ',2a) + 1000 format(3a) + return + end subroutine reffa diff --git a/src/appl/rcsfgenerate90/reffa_I.f90 b/src/appl/rcsfgenerate90/reffa_I.f90 index ab2b1c8b5..befde9066 100644 --- a/src/appl/rcsfgenerate90/reffa_I.f90 +++ b/src/appl/rcsfgenerate90/reffa_I.f90 @@ -1,10 +1,10 @@ - MODULE reffa_I + MODULE reffa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE reffa (POSN, POSL) - integer, DIMENSION(110), INTENT(INOUT) :: POSN - integer, DIMENSION(110), INTENT(INOUT) :: POSL +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE reffa (POSN, POSL) + integer, DIMENSION(110), INTENT(INOUT) :: POSN + integer, DIMENSION(110), INTENT(INOUT) :: POSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/slug.f90 b/src/appl/rcsfgenerate90/slug.f90 index b7a531c43..919cdfb4c 100644 --- a/src/appl/rcsfgenerate90/slug.f90 +++ b/src/appl/rcsfgenerate90/slug.f90 @@ -1,65 +1,65 @@ - + ! last edited November 2, 1995 subroutine slug(i, j, varmax, varupp, varned, ansats, org, lock, dubbel, & - low, start, stopp) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + low, start, stopp) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i - integer , intent(in) :: j - integer , intent(in) :: varmax - integer , intent(out) :: start - integer , intent(out) :: stopp - logical , intent(in) :: lock - integer , intent(inout) :: varupp(15,0:10) - integer , intent(inout) :: varned(15,0:10) - integer , intent(in) :: ansats(15,0:10,0:1) - integer , intent(in) :: org(15,0:10) - integer , intent(in) :: low(15,0:10) - logical , intent(in) :: dubbel(15,0:10) + integer , intent(in) :: i + integer , intent(in) :: j + integer , intent(in) :: varmax + integer , intent(out) :: start + integer , intent(out) :: stopp + logical , intent(in) :: lock + integer , intent(inout) :: varupp(15,0:10) + integer , intent(inout) :: varned(15,0:10) + integer , intent(in) :: ansats(15,0:10,0:1) + integer , intent(in) :: org(15,0:10) + integer , intent(in) :: low(15,0:10) + logical , intent(in) :: dubbel(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: minmax, iold, jold + integer :: minmax, iold, jold !----------------------------------------------- - if (i == 1) then - varupp(1,0) = 0 - varned(1,0) = 0 - else - if (j == 0) then - iold = i - 1 - jold = min(10,iold - 1) - else - iold = i - jold = j - 1 - endif - if (jold == 0) then + if (i == 1) then + varupp(1,0) = 0 + varned(1,0) = 0 + else + if (j == 0) then + iold = i - 1 + jold = min(10,iold - 1) + else + iold = i + jold = j - 1 + endif + if (jold == 0) then varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)-org(& - iold,jold)) + iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)) - else + jold,0)) + else varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)+ansats(& - iold,jold,1)-org(iold,jold)) + iold,jold,1)-org(iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)-ansats(iold,jold,1)) - endif - endif - if (lock) then - start = org(i,j) - stopp = org(i,j) - return - endif - if (j >= 5) then - minmax = 4 - else - minmax = 4*j + 2 - endif - start = min(minmax,org(i,j)+(varmax-varupp(i,j))) - if (dubbel(i,j)) start = 2*(start/2) - stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) - return - end subroutine slug + jold,0)-ansats(iold,jold,1)) + endif + endif + if (lock) then + start = org(i,j) + stopp = org(i,j) + return + endif + if (j >= 5) then + minmax = 4 + else + minmax = 4*j + 2 + endif + start = min(minmax,org(i,j)+(varmax-varupp(i,j))) + if (dubbel(i,j)) start = 2*(start/2) + stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) + return + end subroutine slug diff --git a/src/appl/rcsfgenerate90/slug_I.f90 b/src/appl/rcsfgenerate90/slug_I.f90 index 7f5377bd7..a94306059 100644 --- a/src/appl/rcsfgenerate90/slug_I.f90 +++ b/src/appl/rcsfgenerate90/slug_I.f90 @@ -1,20 +1,20 @@ - MODULE slug_I + MODULE slug_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE slug (I, J, VARMAX, VARUPP, VARNED, ANSATS, ORG, LOCK, DUBBEL& - , LOW, START, STOPP) - integer, INTENT(IN) :: I - integer, INTENT(IN) :: J - integer, INTENT(IN) :: VARMAX - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - logical, INTENT(IN) :: LOCK - logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL - integer, DIMENSION(15,0:10), INTENT(IN) :: LOW - integer, INTENT(OUT) :: START - integer, INTENT(OUT) :: STOPP - END SUBROUTINE - END INTERFACE - END MODULE + , LOW, START, STOPP) + integer, INTENT(IN) :: I + integer, INTENT(IN) :: J + integer, INTENT(IN) :: VARMAX + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + logical, INTENT(IN) :: LOCK + logical, DIMENSION(15,0:10), INTENT(IN) :: DUBBEL + integer, DIMENSION(15,0:10), INTENT(IN) :: LOW + integer, INTENT(OUT) :: START + integer, INTENT(OUT) :: STOPP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/sluggo.f90 b/src/appl/rcsfgenerate90/sluggo.f90 index 706581b00..f5b9a8875 100644 --- a/src/appl/rcsfgenerate90/sluggo.f90 +++ b/src/appl/rcsfgenerate90/sluggo.f90 @@ -1,63 +1,63 @@ - + ! last edited September 23, 1995 subroutine sluggo(i, j, varmax, varupp, varned, ansats, org, lock, low, & - start, stopp) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + start, stopp) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: i - integer , intent(in) :: j - integer , intent(in) :: varmax - integer , intent(out) :: start - integer , intent(out) :: stopp - logical , intent(in) :: lock - integer , intent(inout) :: varupp(15,0:10) - integer , intent(inout) :: varned(15,0:10) - integer , intent(in) :: ansats(15,0:10,0:1) - integer , intent(in) :: org(15,0:10) - integer , intent(in) :: low(15,0:10) + integer , intent(in) :: i + integer , intent(in) :: j + integer , intent(in) :: varmax + integer , intent(out) :: start + integer , intent(out) :: stopp + logical , intent(in) :: lock + integer , intent(inout) :: varupp(15,0:10) + integer , intent(inout) :: varned(15,0:10) + integer , intent(in) :: ansats(15,0:10,0:1) + integer , intent(in) :: org(15,0:10) + integer , intent(in) :: low(15,0:10) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: minmax, iold, jold + integer :: minmax, iold, jold !----------------------------------------------- - if (i == 1) then - varupp(1,0) = 0 - varned(1,0) = 0 - else - if (j == 0) then - iold = i - 1 - jold = min(10,iold - 1) - else - iold = i - jold = j - 1 - endif - if (jold == 0) then + if (i == 1) then + varupp(1,0) = 0 + varned(1,0) = 0 + else + if (j == 0) then + iold = i - 1 + jold = min(10,iold - 1) + else + iold = i + jold = j - 1 + endif + if (jold == 0) then varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)-org(& - iold,jold)) + iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)) - else + jold,0)) + else varupp(i,j) = varupp(iold,jold) + max(0,ansats(iold,jold,0)+ansats(& - iold,jold,1)-org(iold,jold)) + iold,jold,1)-org(iold,jold)) varned(i,j) = varned(iold,jold) + max(0,org(iold,jold)-ansats(iold,& - jold,0)-ansats(iold,jold,1)) - endif - endif - if (lock) then - start = org(i,j) - stopp = org(i,j) - return - endif - if (j >= 5) then - minmax = 4 - else - minmax = 4*j + 2 - endif - start = min(minmax,org(i,j)+(varmax-varupp(i,j))) - stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) - return - end subroutine sluggo + jold,0)-ansats(iold,jold,1)) + endif + endif + if (lock) then + start = org(i,j) + stopp = org(i,j) + return + endif + if (j >= 5) then + minmax = 4 + else + minmax = 4*j + 2 + endif + start = min(minmax,org(i,j)+(varmax-varupp(i,j))) + stopp = max(low(i,j),org(i,j)-(varmax-varned(i,j))) + return + end subroutine sluggo diff --git a/src/appl/rcsfgenerate90/sluggo_I.f90 b/src/appl/rcsfgenerate90/sluggo_I.f90 index 8b2e3bf62..a53add9f6 100644 --- a/src/appl/rcsfgenerate90/sluggo_I.f90 +++ b/src/appl/rcsfgenerate90/sluggo_I.f90 @@ -1,19 +1,19 @@ - MODULE sluggo_I + MODULE sluggo_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 SUBROUTINE sluggo (I, J, VARMAX, VARUPP, VARNED, ANSATS, ORG, LOCK, LOW& - , START, STOPP) - integer, INTENT(IN) :: I - integer, INTENT(IN) :: J - integer, INTENT(IN) :: VARMAX - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP - integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS - integer, DIMENSION(15,0:10), INTENT(IN) :: ORG - logical, INTENT(IN) :: LOCK - integer, DIMENSION(15,0:10), INTENT(IN) :: LOW - integer, INTENT(OUT) :: START - integer, INTENT(OUT) :: STOPP - END SUBROUTINE - END INTERFACE - END MODULE + , START, STOPP) + integer, INTENT(IN) :: I + integer, INTENT(IN) :: J + integer, INTENT(IN) :: VARMAX + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARUPP + integer, DIMENSION(15,0:10), INTENT(INOUT) :: VARNED + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: ANSATS + integer, DIMENSION(15,0:10), INTENT(IN) :: ORG + logical, INTENT(IN) :: LOCK + integer, DIMENSION(15,0:10), INTENT(IN) :: LOW + integer, INTENT(OUT) :: START + integer, INTENT(OUT) :: STOPP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/test.f90 b/src/appl/rcsfgenerate90/test.f90 index c855ae30f..7b436bc0d 100644 --- a/src/appl/rcsfgenerate90/test.f90 +++ b/src/appl/rcsfgenerate90/test.f90 @@ -1,47 +1,47 @@ ! last edited October 31, 1996 - subroutine test(p1, p2, pop1, pop2, nmax) -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 -!...Switches: + subroutine test(p1, p2, pop1, pop2, nmax) +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 +!...Switches: implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: nmax - logical , intent(out) :: p1 - logical , intent(out) :: p2 - integer , intent(in) :: pop1(15,0:10,0:1) - integer , intent(in) :: pop2(15,0:10,0:1) + integer , intent(in) :: nmax + logical , intent(out) :: p1 + logical , intent(out) :: p2 + integer , intent(in) :: pop1(15,0:10,0:1) + integer , intent(in) :: pop2(15,0:10,0:1) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: n, l, k + integer :: n, l, k !----------------------------------------------- - - p1 = .TRUE. - p2 = .TRUE. - do n = 1, nmax - do l = 0, min(10,n - 1) - if (pop1(n,l,1) + pop1(n,l,0) < pop2(n,l,1) + pop2(n,l,0)) then - p1 = .FALSE. - return + + p1 = .TRUE. + p2 = .TRUE. + do n = 1, nmax + do l = 0, min(10,n - 1) + if (pop1(n,l,1) + pop1(n,l,0) < pop2(n,l,1) + pop2(n,l,0)) then + p1 = .FALSE. + return else if (pop1(n,l,1) + pop1(n,l,0) > pop2(n,l,1) + pop2(n,l,0)) & - then - p2 = .FALSE. - return - else if (pop1(n,l,1) < pop2(n,l,1)) then - p1 = .FALSE. - return - else if (pop1(n,l,1) > pop2(n,l,1)) then - p2 = .FALSE. - return - else if (pop1(n,l,0) < pop2(n,l,0)) then - p1 = .FALSE. - return - else if (pop1(n,l,0) > pop2(n,l,0)) then - p2 = .FALSE. - return - endif - end do - end do - return - end subroutine test + then + p2 = .FALSE. + return + else if (pop1(n,l,1) < pop2(n,l,1)) then + p1 = .FALSE. + return + else if (pop1(n,l,1) > pop2(n,l,1)) then + p2 = .FALSE. + return + else if (pop1(n,l,0) < pop2(n,l,0)) then + p1 = .FALSE. + return + else if (pop1(n,l,0) > pop2(n,l,0)) then + p2 = .FALSE. + return + endif + end do + end do + return + end subroutine test diff --git a/src/appl/rcsfgenerate90/test_I.f90 b/src/appl/rcsfgenerate90/test_I.f90 index 282a83ee6..cfaa308d8 100644 --- a/src/appl/rcsfgenerate90/test_I.f90 +++ b/src/appl/rcsfgenerate90/test_I.f90 @@ -1,12 +1,12 @@ - MODULE test_I + MODULE test_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 - SUBROUTINE test (P1, P2, POP1, POP2, NMAX) - logical, INTENT(OUT) :: P1 - logical, INTENT(OUT) :: P2 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 - integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP2 - integer, INTENT(IN) :: NMAX - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:44:54 12/27/06 + SUBROUTINE test (P1, P2, POP1, POP2, NMAX) + logical, INTENT(OUT) :: P1 + logical, INTENT(OUT) :: P2 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP1 + integer, DIMENSION(15,0:10,0:1), INTENT(IN) :: POP2 + integer, INTENT(IN) :: NMAX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfgenerate90/wrapper.f90 b/src/appl/rcsfgenerate90/wrapper.f90 index e76cf9c4b..e01d27b4f 100644 --- a/src/appl/rcsfgenerate90/wrapper.f90 +++ b/src/appl/rcsfgenerate90/wrapper.f90 @@ -1,7 +1,6 @@ program wrapper -call rcsfexcitation +call rcsfexcitation call jjgen15 end program wrapper - diff --git a/src/appl/rcsfinteract90/Interact_MR.f90 b/src/appl/rcsfinteract90/Interact_MR.f90 index 2c68b81ba..3d3d6e741 100644 --- a/src/appl/rcsfinteract90/Interact_MR.f90 +++ b/src/appl/rcsfinteract90/Interact_MR.f90 @@ -17,7 +17,7 @@ SUBROUTINE Interact_MR(ICOLBREI,I_Count) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man !----------------------------------------------- @@ -40,7 +40,7 @@ SUBROUTINE Interact_MR(ICOLBREI,I_Count) INTEGER :: JA, JB, int_CSF !----------------------------------------------- ! - DO JA = 1, NCFBLK(NBLOCK) + DO JA = 1, NCFBLK(NBLOCK) JB = NCFBLK(NBLOCK) + 1 CALL Interact_CSF(JA,JB,ICOLBREI,int_CSF) if(int_CSF .NE. 0) THEN @@ -50,6 +50,6 @@ SUBROUTINE Interact_MR(ICOLBREI,I_Count) WRITE(22,'(A)') TRIM(C_coupl(JB)) RETURN END IF - END DO - RETURN + END DO + RETURN END SUBROUTINE Interact_MR diff --git a/src/appl/rcsfinteract90/Interact_csf.f90 b/src/appl/rcsfinteract90/Interact_csf.f90 index f519ab195..31d3943d4 100644 --- a/src/appl/rcsfinteract90/Interact_csf.f90 +++ b/src/appl/rcsfinteract90/Interact_csf.f90 @@ -109,7 +109,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF END IF ELSE ! @@ -119,7 +119,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF END IF END DO END DO @@ -295,7 +295,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF ELSE ! ! TARP TU PACIU KONFIGURACIJU @@ -304,7 +304,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF END IF END DO IF ((IDQ .EQ. 0) .AND. (NCORE .EQ. 0)) CYCLE @@ -378,7 +378,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF END IF ELSE WRITE(99,994) @@ -392,7 +392,7 @@ SUBROUTINE Interact_CSF(JA,JB,ICOLBREI,int_CSF) IF(INTERACT .NE. 0) THEN int_CSF = 1 RETURN - END IF + END IF NPEEL = NPEEL-1 NPEELM = NPEEL-1 DO I = 1,NPEEL diff --git a/src/appl/rcsfinteract90/Makefile b/src/appl/rcsfinteract90/Makefile old mode 100755 new mode 100644 index 7d1f3ed10..9eac3eb20 --- a/src/appl/rcsfinteract90/Makefile +++ b/src/appl/rcsfinteract90/Makefile @@ -10,7 +10,7 @@ MODL9290 = ${SRCLIBDIR}/lib9290 MODLRANG90 = ${SRCLIBDIR}/librang90 GRASPLIBS =-l9290 -lmod -lrang90 -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} # Define data types VASTO = ${MODDIR}/vast_kind_param_M.o @@ -30,11 +30,11 @@ APP_OBJ= \ onescalarINT.o onescalar1INT.o onescalar2INT.o \ el1INT.o el2INT.o el3INT.o el31INT.o el32INT.o el33INT.o \ el4INT.o el41INT.o \ - el5INT.o el51INT.o el52INT.o el53INT.o Interact_csf.o + el5INT.o el51INT.o el52INT.o el53INT.o Interact_csf.o $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) + $(APP_LIBS) diff --git a/src/appl/rcsfinteract90/RCSFinteract.f90 b/src/appl/rcsfinteract90/RCSFinteract.f90 index 8fea71ff4..46bc83ea1 100644 --- a/src/appl/rcsfinteract90/RCSFinteract.f90 +++ b/src/appl/rcsfinteract90/RCSFinteract.f90 @@ -12,10 +12,10 @@ PROGRAM RCSFinteract ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man - USE default_C + USE default_C USE BLK_C, only: NBLOCK,NCFBLK USE orb_C USE STAT_C @@ -24,10 +24,10 @@ PROGRAM RCSFinteract ! I n t e r f a c e B l o c k s !----------------------------------------------- USE Interact_MR_I - USE set_CSF_list_I + USE set_CSF_list_I USE lodcsl_MR_I USE lodcsl_CSF_I - USE factt_I + USE factt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -50,15 +50,15 @@ PROGRAM RCSFinteract print *, 'Dirac-Coulomb-Breit (2) Hamiltonian?' READ(*,*) ICOLBREI ! - NBLOCK = 0 - CALL FACTT + NBLOCK = 0 + CALL FACTT CALL SET_CSF_list (NCORE,NPEEL) WRITE (6, *) " Block MR NCSF Before NCSF After NCSF" DO I_Count = 0 CALL LODCSL_MR (NCORE,NPEEL,NCFD,NEXT_BLOCK) CSF_Number = 0 - DO + DO CSF_Number = CSF_Number + 1 CALL LODCSL_CSF (NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) IF(.NOT. NEXT_CSF) EXIT @@ -72,14 +72,14 @@ PROGRAM RCSFinteract deallocate (C_shell) deallocate (C_quant) deallocate (C_coupl) - deallocate (iqa) - deallocate (jqsa) + deallocate (iqa) + deallocate (jqsa) deallocate (jcupa) ! IF(.NOT. NEXT_BLOCK) EXIT - WRITE(22,'(A2)') ' *' + WRITE(22,'(A2)') ' *' END DO - CLOSE(24) + CLOSE(24) call stoptime (ncount1, 'RCSFinteract') - STOP + STOP END PROGRAM RCSFinteract diff --git a/src/appl/rcsfinteract90/el1INT.f90 b/src/appl/rcsfinteract90/el1INT.f90 index c7266613f..f0d91f965 100644 --- a/src/appl/rcsfinteract90/el1INT.f90 +++ b/src/appl/rcsfinteract90/el1INT.f90 @@ -44,14 +44,14 @@ SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI + INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI INTEGER, INTENT(OUT) :: INTERACT ! DIMENSION CONE(7,20),S(12),IS(4),KAPS(4),KS(4) ! DIMENSION PMGG(30),RAGG(30),J(2) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II,IA,IB,IAT,IP1,IP2,IP3,IG1,IG2,IG3,IKK,I1,I2,I3,I4,& + INTEGER :: II,IA,IB,IAT,IP1,IP2,IP3,IG1,IG2,IG3,IKK,I1,I2,I3,I4,& IFAZ,J12,IBRD,IBRE,KRA,KRA1,L1,L2,MU,N,NU,ND1,ND2, & NE1,NE2,NUP1 INTEGER :: INTERACT1, INTERACT2 @@ -62,7 +62,7 @@ SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) ! REAL(DOUBLE), DIMENSION(12) :: S ! REAL(DOUBLE), DIMENSION(30) :: PMGG,RAGG REAL(DOUBLE), DIMENSION(30) :: PMGG -! REAL(DOUBLE), DIMENSION(7,20) :: CONE +! REAL(DOUBLE), DIMENSION(7,20) :: CONE !----------------------------------------------- INTERACT = 0 IF(JA.NE.JB)GO TO 9 @@ -102,7 +102,7 @@ SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) KS(3)=IABS(KAPS(3)) KS(4)=IABS(KAPS(4)) CALL SNRC(IS,KAPS,KS,ND1,ND2,NE1,NE2,IBRD,IBRE) - IF(IBRD .LE. 0)RETURN + IF(IBRD .LE. 0)RETURN END IF DO I2=IP1,IG1,2 KRA=(I2-1)/2 @@ -216,8 +216,8 @@ SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) ! CONE(6,II)=ZERO ! CONE(7,II)=ZERO ! END DO - IF(IBRD .EQ. 0 .AND. IBRE .EQ.0)RETURN -! IF(IBRD .LE. 0 .AND. IBRE .LE. 0)RETURN + IF(IBRD .EQ. 0 .AND. IBRE .EQ.0)RETURN +! IF(IBRD .LE. 0 .AND. IBRE .LE. 0)RETURN END IF DO I1=IP1,IG1,2 KRA=(I1-1)/2 @@ -289,7 +289,7 @@ SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) ELSE IF (ICOLBREI .EQ. 2) THEN INTERACT = 1 RETURN -! NU=KRA +! NU=KRA ! IF(((NU-NE1)/2)*2 .EQ. (NU-NE1)) THEN ! IF((ITRIG(KS(1),KS(4),NU+NU+1).NE.0) .AND. & ! (ITRIG(KS(2),KS(3),NU+NU+1).NE.0)) THEN diff --git a/src/appl/rcsfinteract90/el1INT_I.f90 b/src/appl/rcsfinteract90/el1INT_I.f90 index 287c86ce3..b764d7826 100644 --- a/src/appl/rcsfinteract90/el1INT_I.f90 +++ b/src/appl/rcsfinteract90/el1INT_I.f90 @@ -2,7 +2,7 @@ MODULE el1INT_I INTERFACE ! SUBROUTINE EL1INT(JJA,JJB,JA,JB,IIRE,ICOLBREI,INTERACT) - INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI + INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI INTEGER, INTENT(OUT) :: INTERACT END SUBROUTINE END INTERFACE diff --git a/src/appl/rcsfinteract90/getinf.f90 b/src/appl/rcsfinteract90/getinf.f90 index c01385276..a270d7df2 100644 --- a/src/appl/rcsfinteract90/getinf.f90 +++ b/src/appl/rcsfinteract90/getinf.f90 @@ -49,7 +49,7 @@ SUBROUTINE GETINF ! DIAG = GETYN () ! ELSE ! DIAG = .FALSE. -! ENDIF +! ENDIF DIAG = .FALSE. IF (DIAG) THEN LFORDR = .FALSE. diff --git a/src/appl/rcsfinteract90/getinf_I.f90 b/src/appl/rcsfinteract90/getinf_I.f90 index 18262db7a..76000a53c 100644 --- a/src/appl/rcsfinteract90/getinf_I.f90 +++ b/src/appl/rcsfinteract90/getinf_I.f90 @@ -1,7 +1,7 @@ - MODULE getinf_I + MODULE getinf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 - SUBROUTINE getinf - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/ 5/07 + SUBROUTINE getinf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfinteract90/lodcsl_CSF.f90 b/src/appl/rcsfinteract90/lodcsl_CSF.f90 index 2b2021fe6..d79d27ad5 100644 --- a/src/appl/rcsfinteract90/lodcsl_CSF.f90 +++ b/src/appl/rcsfinteract90/lodcsl_CSF.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) + SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -12,31 +12,31 @@ SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE ORB_C + USE DEBUG_C + USE DEF_C + USE ORB_C USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C USE BLK_C, only: NBLOCK,NCFBLK USE memory_man USE rang_Int_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -47,21 +47,21 @@ SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: IOCC - INTEGER , DIMENSION(NW2) :: IQSUB - INTEGER , DIMENSION(NNNW) :: JX + INTEGER , DIMENSION(NNNW) :: IOCC + INTEGER , DIMENSION(NW2) :: IQSUB + INTEGER , DIMENSION(NNNW) :: JX INTEGER :: I INTEGER :: NCORP1, J, NPJ, NAKJ, LENTH, NREC & , IOS, IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN & , NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU & - , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECL - CHARACTER(LEN=256) :: RECORD + , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECL + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! Initial allocation for arrays with a dimension dependent @@ -70,48 +70,48 @@ SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) ! Found_CSF = 0 NEXT_CSF = .TRUE. - IF(CSF_Number .EQ. 1) NCF = NCFBLK(NBLOCK) + 1 - NREC = 5 + IF(CSF_Number .EQ. 1) NCF = NCFBLK(NBLOCK) + 1 + NREC = 5 ! - 3 CONTINUE + 3 CONTINUE ! - READ (20, '(A)', IOSTAT=IOS) RECORD - IF (RECORD(1:2) == ' *') THEN + READ (20, '(A)', IOSTAT=IOS) RECORD + IF (RECORD(1:2) == ' *') THEN NEXT_CSF = .FALSE. RETURN - ENDIF - C_shell(NCF) = RECORD - IF (IOS == 0) THEN + ENDIF + C_shell(NCF) = RECORD + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (20, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (20, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Expecting subshell quantum', & - ' number specification;' - GO TO 26 - ENDIF + ' number specification;' + GO TO 26 + ENDIF C_quant(NCF) = RECORD - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (20, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (20, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF C_coupl(NCF) = RECORD IF(NotFound >= 1) THEN DO I =1,NCF-1 @@ -123,12 +123,12 @@ SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) NotFound = NotFound - 1 Found_CSF = 1 RETURN - ENDIF - ENDIF - ENDIF - ENDIF + ENDIF + ENDIF + ENDIF + ENDIF END DO - ENDIF + ENDIF ! ! Zero out the arrays that store packed integers ! @@ -143,293 +143,293 @@ SUBROUTINE LODCSL_CSF(NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) 'LODCSL_CSF: Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 NCORP1 = NCORE + 1 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too few subshell quantum', & - ' numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + ' numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) 'LODCSL_CSF: Subshell quantum numbers ', & 'specified incorrectly for '//RECORD(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) & - 'LODCSL_CSF: subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + 'LODCSL_CSF: subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) 'LODCSL_CSF: Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) 'LODCSL_CSF: Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) 'LODCSL_CSF: Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! -! NREC = NREC + 3 -! GO TO 3 +! NREC = NREC + 3 +! GO TO 3 RETURN - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE NEXT_CSF = .FALSE. RETURN - ENDIF + ENDIF ! - ENDIF + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs; eliminating this', ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) + ' in all CSFs; eliminating this', ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL -! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL +! + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF NEXT_CSF = .FALSE. ! - RETURN + RETURN ! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' WRITE (ISTDE, *) TRIM(C_shell(NCF)) WRITE (ISTDE, *) TRIM(C_quant(NCF)) WRITE (ISTDE, *) TRIM(C_coupl(NCF)) - 29 CLOSE(20) - STOP + 29 CLOSE(20) + STOP ! END SUBROUTINE LODCSL_CSF diff --git a/src/appl/rcsfinteract90/lodcsl_CSF_I.f90 b/src/appl/rcsfinteract90/lodcsl_CSF_I.f90 index 0cf502100..09921d4aa 100644 --- a/src/appl/rcsfinteract90/lodcsl_CSF_I.f90 +++ b/src/appl/rcsfinteract90/lodcsl_CSF_I.f90 @@ -1,10 +1,10 @@ - MODULE lodcsl_CSF_I + MODULE lodcsl_CSF_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 - SUBROUTINE lodcsl_CSF (NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 + SUBROUTINE lodcsl_CSF (NCFD,CSF_Number,NCORE,NPEEL,NEXT_CSF) INTEGER, INTENT(IN) :: CSF_Number, NCORE INTEGER, INTENT(INOUT) :: NPEEL,NCFD LOGICAL, INTENT(OUT) :: NEXT_CSF - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfinteract90/lodcsl_MR.f90 b/src/appl/rcsfinteract90/lodcsl_MR.f90 index 5de59aeb3..2c2036bef 100644 --- a/src/appl/rcsfinteract90/lodcsl_MR.f90 +++ b/src/appl/rcsfinteract90/lodcsl_MR.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) + SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -12,31 +12,31 @@ SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE ORB_C + USE DEBUG_C + USE DEF_C + USE ORB_C USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C USE BLK_C, only: NBLOCK,NCFBLK USE memory_man USE rang_Int_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -44,25 +44,25 @@ SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) INTEGER, INTENT(IN) :: NCORE INTEGER, INTENT(INOUT) :: NPEEL INTEGER, INTENT(OUT) :: NCFD - LOGICAL, INTENT(OUT) :: NEXT_BLOCK + LOGICAL, INTENT(OUT) :: NEXT_BLOCK !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER, DIMENSION(NW2) :: IQSUB - INTEGER, DIMENSION(NNNW) :: JX + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER, DIMENSION(NW2) :: IQSUB + INTEGER, DIMENSION(NNNW) :: JX INTEGER :: I INTEGER :: NCORP1, J, NPJ, NAKJ, LENTH, NREC & , IOS, IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN & , NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU & - , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECL - CHARACTER(LEN=256) :: RECORD + , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECL + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! Initial allocation for arrays with a dimension dependent @@ -78,52 +78,52 @@ SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) allocate (IQA(NNNW,NCFD+1)) allocate (JQSA(NNNW,3,NCFD+1)) allocate (JCUPA(NNNW,NCFD+1)) - NREC = 5 - NCF = 0 - 3 CONTINUE - NCF = NCF + 1 -! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (RECORD(1:2) == ' *') THEN - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF - 1 + NREC = 5 + NCF = 0 + 3 CONTINUE + NCF = NCF + 1 +! + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (RECORD(1:2) == ' *') THEN + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF - 1 NotFound = NCFBLK(NBLOCK) Found(1:NotFound) = 0 NEXT_BLOCK = .TRUE. RETURN - ENDIF + ENDIF C_shell(NCF) = RECORD - IF (IOS == 0) THEN + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting subshell quantum', & - ' number specification;' - GO TO 26 - ENDIF - READ (21, '(A)', IOSTAT=IOS) RECORD + ' number specification;' + GO TO 26 + ENDIF + READ (21, '(A)', IOSTAT=IOS) RECORD C_quant(NCF) = RECORD - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF C_coupl(NCF) = RECORD WRITE(22,'(A)') TRIM(C_shell(NCF)) WRITE(22,'(A)') TRIM(C_quant(NCF)) @@ -142,289 +142,289 @@ SUBROUTINE LODCSL_MR(NCORE,NPEEL,NCFD,NEXT_BLOCK) ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) 'LODCSL: Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 NCORP1 = NCORE + 1 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell quantum', & - ' numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + ' numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) 'LODCSL: Subshell quantum numbers ', & 'specified incorrectly for '//RECORD(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) & 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I),& - ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) 'LODCSL: Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) 'LODCSL: Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! - IF (NCF > 1) THEN - DO J = 1, NCF - 1 - DO I = NCORP1, NW - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (NCF > 1) THEN + DO J = 1, NCF - 1 + DO I = NCORP1, NW + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF - I = NCORP1 + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF + I = NCORP1 ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL -! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL +! + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF NotFound = NCFBLK(NBLOCK) Found(1:NotFound) = 0 NEXT_BLOCK = .FALSE. ! - RETURN + RETURN ! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 READ (21,'(A)',ERR = 29,END = 29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (ISTDE, *) RECORD(1:LENTH) - END DO - 29 CLOSE(21) - STOP + LENTH = LEN_TRIM(RECORD) + WRITE (ISTDE, *) RECORD(1:LENTH) + END DO + 29 CLOSE(21) + STOP ! END SUBROUTINE LODCSL_MR diff --git a/src/appl/rcsfinteract90/onescalarINT.f90 b/src/appl/rcsfinteract90/onescalarINT.f90 index 873bc6c2e..c072bd47d 100644 --- a/src/appl/rcsfinteract90/onescalarINT.f90 +++ b/src/appl/rcsfinteract90/onescalarINT.f90 @@ -172,7 +172,7 @@ SUBROUTINE ONESCALARINT(JA,JB,IA1,IA2,INTERACT) ELSE INTERACT = 0 END IF - ELSE IF (IDQ .EQ. 2) THEN + ELSE IF (IDQ .EQ. 2) THEN ! ! IDQ = 2 Case ! diff --git a/src/appl/rcsfinteract90/set_CSF_list.f90 b/src/appl/rcsfinteract90/set_CSF_list.f90 index 86ccd0f82..f5cb49b54 100644 --- a/src/appl/rcsfinteract90/set_CSF_list.f90 +++ b/src/appl/rcsfinteract90/set_CSF_list.f90 @@ -18,7 +18,7 @@ SUBROUTINE SET_CSF_list(NCORE,NPEEL) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I USE prsrsl_I USE convrt_I IMPLICIT NONE @@ -30,41 +30,41 @@ SUBROUTINE SET_CSF_list(NCORE,NPEEL) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IERR, IOS, I, J, LENTH, NAKJ, NCORP1, NPJ - LOGICAL :: FOUND + LOGICAL :: FOUND CHARACTER :: NAME*24, FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 CHARACTER :: RECORD_1*15, RECORD_2*15 CHARACTER :: S_closed_1*181, S_closed_2*181 CHARACTER :: S_orbitals_1*1070, S_orbitals_2*1070 !----------------------------------------------- ! - WRITE (6, *) 'Loading Configuration Symmetry List File ...' - FILNAM = 'rcsfmr.inp' - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + WRITE (6, *) 'Loading Configuration Symmetry List File ...' + FILNAM = 'rcsfmr.inp' + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF READ (21, '(1A15)', IOSTAT=IOS) RECORD_1 - IF (IOS/=0 .OR. RECORD_1(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF -! - FILNAM = 'rcsf.inp' - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (20, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + IF (IOS/=0 .OR. RECORD_1(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF +! + FILNAM = 'rcsf.inp' + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (20, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF READ (20, '(1A15)', IOSTAT=IOS) RECORD_2 - IF (IOS/=0 .OR. RECORD_2(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(20) - ENDIF + IF (IOS/=0 .OR. RECORD_2(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(20) + ENDIF ! READ (21, '(A)') S_closed_1 READ (20, '(A)') S_closed_2 @@ -72,10 +72,10 @@ SUBROUTINE SET_CSF_list(NCORE,NPEEL) STOP "Different close shells" end if ! - FILNAM = 'rcsf.out' - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) + FILNAM = 'rcsf.out' + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) WRITE (22, '(1A15)') RECORD_1 I = LEN_TRIM(S_closed_1) WRITE (22,'(A)') S_closed_1(1:I) @@ -102,46 +102,46 @@ SUBROUTINE SET_CSF_list(NCORE,NPEEL) ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (20, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (20, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (20, *) - CALL PRSRSL (20, 2) - NPEEL = NW - NCORE + READ (20, *) + CALL PRSRSL (20, 2) + NPEEL = NW - NCORE ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'SET_CSF_list: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) 'There are '//RECORD(1:LENTH)// & - ' relativistic subshells;' - ELSE - WRITE (6, *) 'There is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) 'There is 1 relativistic subshell;' + ENDIF READ (20, *) ! - RETURN + RETURN END SUBROUTINE SET_CSF_list diff --git a/src/appl/rcsfinteract90/set_CSF_list_I.f90 b/src/appl/rcsfinteract90/set_CSF_list_I.f90 index 01519cd68..97f7075a2 100644 --- a/src/appl/rcsfinteract90/set_CSF_list_I.f90 +++ b/src/appl/rcsfinteract90/set_CSF_list_I.f90 @@ -1,8 +1,8 @@ - MODULE set_CSF_list_I + MODULE set_CSF_list_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:49:50 12/27/06 +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:49:50 12/27/06 SUBROUTINE set_CSF_list (NCORE,NPEEL) INTEGER, INTENT(OUT) :: NCORE,NPEEL - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfinteract90/set_CSF_number.f90 b/src/appl/rcsfinteract90/set_CSF_number.f90 index 3144d6f59..5ce9d166a 100644 --- a/src/appl/rcsfinteract90/set_CSF_number.f90 +++ b/src/appl/rcsfinteract90/set_CSF_number.f90 @@ -42,7 +42,7 @@ SUBROUTINE SET_CSF_number READ (21, '(A)') S_orbitals ! Read the X, J, and (sign of) P quantum numbers READ (21, '(A)') S_orbitals - CYCLE + CYCLE END IF EXIT END DO @@ -58,5 +58,5 @@ SUBROUTINE SET_CSF_number ! Peel orbitals READ (21, '(A)') S_orbitals READ (21, '(1A7)') RECORD - RETURN + RETURN END SUBROUTINE SET_CSF_number diff --git a/src/appl/rcsfinteract90/set_CSF_number_I.f90 b/src/appl/rcsfinteract90/set_CSF_number_I.f90 index 87f615140..aa3d0dd11 100644 --- a/src/appl/rcsfinteract90/set_CSF_number_I.f90 +++ b/src/appl/rcsfinteract90/set_CSF_number_I.f90 @@ -1,6 +1,6 @@ - MODULE set_CSF_number_I + MODULE set_CSF_number_I INTERFACE - SUBROUTINE set_CSF_number - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE set_CSF_number + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfzerofirst90/Makefile b/src/appl/rcsfzerofirst90/Makefile old mode 100755 new mode 100644 index e50350cef..ea1df2db3 --- a/src/appl/rcsfzerofirst90/Makefile +++ b/src/appl/rcsfzerofirst90/Makefile @@ -24,7 +24,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) + $(APP_LIBS) .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL9290} -I $(MODDIR) -o $@ diff --git a/src/appl/rcsfzerofirst90/RCSFzerofirst.f90 b/src/appl/rcsfzerofirst90/RCSFzerofirst.f90 old mode 100755 new mode 100644 index 64526c3ee..288edb916 --- a/src/appl/rcsfzerofirst90/RCSFzerofirst.f90 +++ b/src/appl/rcsfzerofirst90/RCSFzerofirst.f90 @@ -12,14 +12,14 @@ PROGRAM RCSFzerofirst ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE BLK_C, only: NBLOCK,NCFBLK USE rang_Int_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE set_CSF_ZFlist_I + USE set_CSF_ZFlist_I USE lodcsl_Zero_I USE lodcsl_Part_I IMPLICIT NONE @@ -42,7 +42,7 @@ PROGRAM RCSFzerofirst print *, " the zero-order space" print *, " Output file: rcsf.out" print *, "" - NBLOCK = 0 + NBLOCK = 0 CALL SET_CSF_ZFlist WRITE (6, *) " Block Zero-order Space Complete Space" DO @@ -55,8 +55,8 @@ PROGRAM RCSFzerofirst deallocate (C_quant) deallocate (C_coupl) IF(.NOT. NEXT_BLOCK) EXIT - WRITE(22,'(A2)') ' *' + WRITE(22,'(A2)') ' *' END DO call stoptime (ncount1, 'RCSFzerofirst') - STOP + STOP END PROGRAM RCSFzerofirst diff --git a/src/appl/rcsfzerofirst90/lodcsl_Part.f90 b/src/appl/rcsfzerofirst90/lodcsl_Part.f90 old mode 100755 new mode 100644 index eed471a65..558fe090c --- a/src/appl/rcsfzerofirst90/lodcsl_Part.f90 +++ b/src/appl/rcsfzerofirst90/lodcsl_Part.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSL_Part(CSF_Number) + SUBROUTINE LODCSL_Part(CSF_Number) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -10,7 +10,7 @@ SUBROUTINE LODCSL_Part(CSF_Number) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE BLK_C, only: NBLOCK,NCFBLK USE rang_Int_C @@ -30,12 +30,12 @@ SUBROUTINE LODCSL_Part(CSF_Number) !----------------------------------------------- ! CSF_Number = 0 - DO + DO CSF_Number = CSF_Number + 1 Found_CSF = 0 - IF(CSF_Number .EQ. 1) NCF = NCFBLK(NBLOCK) + 1 - READ (20, '(A)', IOSTAT=IOS) RECORD - IF (IOS == 0) THEN + IF(CSF_Number .EQ. 1) NCF = NCFBLK(NBLOCK) + 1 + READ (20, '(A)', IOSTAT=IOS) RECORD + IF (IOS == 0) THEN IF (RECORD(1:2) == ' *') RETURN RECORD_C_shell = RECORD ! @@ -45,7 +45,7 @@ SUBROUTINE LODCSL_Part(CSF_Number) ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (20, '(A)') RECORD_C_coupl + READ (20, '(A)') RECORD_C_coupl IF(NotFound >= 1) THEN DO I =1,NCF-1 IF(Found(I) == 0) THEN @@ -56,10 +56,10 @@ SUBROUTINE LODCSL_Part(CSF_Number) NotFound = NotFound - 1 Found_CSF = 1 CYCLE - ENDIF - ENDIF - ENDIF - ENDIF + ENDIF + ENDIF + ENDIF + ENDIF END DO IF(Found_CSF == 1) CYCLE WRITE(22,'(A)') TRIM(RECORD_C_shell) @@ -69,11 +69,11 @@ SUBROUTINE LODCSL_Part(CSF_Number) WRITE(22,'(A)') TRIM(RECORD_C_shell) WRITE(22,'(A)') TRIM(RECORD_C_quant) WRITE(22,'(A)') TRIM(RECORD_C_coupl) - ENDIF + ENDIF ELSE RETURN - ENDIF + ENDIF END DO - RETURN + RETURN ! END SUBROUTINE LODCSL_Part diff --git a/src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 b/src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 old mode 100755 new mode 100644 index 85f227b12..062aef8de --- a/src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 +++ b/src/appl/rcsfzerofirst90/lodcsl_Part_I.f90 @@ -1,7 +1,7 @@ - MODULE lodcsl_Part_I + MODULE lodcsl_Part_I INTERFACE - SUBROUTINE lodcsl_Part (CSF_Number) + SUBROUTINE lodcsl_Part (CSF_Number) INTEGER, INTENT(OUT) :: CSF_Number - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfzerofirst90/lodcsl_Zero.f90 b/src/appl/rcsfzerofirst90/lodcsl_Zero.f90 old mode 100755 new mode 100644 index 157a1c69d..0da8d4d81 --- a/src/appl/rcsfzerofirst90/lodcsl_Zero.f90 +++ b/src/appl/rcsfzerofirst90/lodcsl_Zero.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSL_Zero(NEXT_BLOCK) + SUBROUTINE LODCSL_Zero(NEXT_BLOCK) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -10,7 +10,7 @@ SUBROUTINE LODCSL_Zero(NEXT_BLOCK) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE BLK_C, only: NBLOCK,NCFBLK USE rang_Int_C @@ -21,12 +21,12 @@ SUBROUTINE LODCSL_Zero(NEXT_BLOCK) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(OUT) :: NEXT_BLOCK + LOGICAL, INTENT(OUT) :: NEXT_BLOCK !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IOS, NCF, NCFD - CHARACTER(LEN=256) :: RECORD + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! Initial allocation for arrays with a dimension dependent @@ -39,23 +39,23 @@ SUBROUTINE LODCSL_Zero(NEXT_BLOCK) allocate (C_shell(NCFD)) allocate (C_quant(NCFD)) allocate (C_coupl(NCFD)) - NCF = 0 + NCF = 0 DO - NCF = NCF + 1 - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS == 0) THEN - IF (RECORD(1:2) == ' *') THEN - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF - 1 + NCF = NCF + 1 + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS == 0) THEN + IF (RECORD(1:2) == ' *') THEN + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF - 1 NotFound = NCFBLK(NBLOCK) Found(1:NotFound) = 0 RETURN - ENDIF + ENDIF C_shell(NCF) = RECORD ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD C_quant(NCF) = RECORD ! ! Read the X, J, and (sign of) P quantum numbers @@ -69,11 +69,11 @@ SUBROUTINE LODCSL_Zero(NEXT_BLOCK) EXIT ENDIF END DO - NBLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + 1 NCFBLK(NBLOCK) = NCF - 1 NotFound = NCFBLK(NBLOCK) Found(1:NotFound) = 0 NEXT_BLOCK = .FALSE. - RETURN + RETURN ! END SUBROUTINE LODCSL_Zero diff --git a/src/appl/rcsfzerofirst90/lodcsl_Zero_I.f90 b/src/appl/rcsfzerofirst90/lodcsl_Zero_I.f90 old mode 100755 new mode 100644 diff --git a/src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 b/src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 old mode 100755 new mode 100644 index 77f083d7c..eeeb872fb --- a/src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 +++ b/src/appl/rcsfzerofirst90/set_CSF_ZFlist.f90 @@ -18,7 +18,7 @@ SUBROUTINE SET_CSF_ZFlist !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I USE prsrsl_I USE convrt_I USE Set_CSF_number_I @@ -36,35 +36,35 @@ SUBROUTINE SET_CSF_ZFlist print *, & "Give the full name of the list that contains the zero-order space" read(*,'(a)') FILNAM - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF READ (21, '(1A15)', IOSTAT=IOS) RECORD_1 - IF (IOS/=0 .OR. RECORD_1(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + IF (IOS/=0 .OR. RECORD_1(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! print *, & "Give the full name of the list that should be partitioned" read(*,'(a)') FILNAM WRITE (6, *) 'Loading Configuration Symmetry List File ...' - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (20, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (20, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF READ (20, '(1A15)', IOSTAT=IOS) RECORD_2 - IF (IOS/=0 .OR. RECORD_2(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(20) - ENDIF + IF (IOS/=0 .OR. RECORD_2(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(20) + ENDIF ! READ (21, '(A)') S_closed_1 READ (20, '(A)') S_closed_2 @@ -72,10 +72,10 @@ SUBROUTINE SET_CSF_ZFlist STOP "Diffeent close shells" end if ! - FILNAM = 'rcsf.out' - FORM = 'FORMATTED' - STATUS = 'OLD' - CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) + FILNAM = 'rcsf.out' + FORM = 'FORMATTED' + STATUS = 'OLD' + CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) WRITE (22, '(1A15)') RECORD_1 I = LEN_TRIM(S_closed_1) WRITE (22,'(A)') S_closed_1(1:I) @@ -102,44 +102,44 @@ SUBROUTINE SET_CSF_ZFlist ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (20, 1) - NCORE = NW + CALL PRSRSL (20, 1) + NCORE = NW ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (20, *) - CALL PRSRSL (20, 2) + READ (20, *) + CALL PRSRSL (20, 2) ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'SET_CSF_list: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) 'There are '//RECORD(1:LENTH)// & - ' relativistic subshells;' - ELSE - WRITE (6, *) 'There is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) 'There is 1 relativistic subshell;' + ENDIF READ (20, *) ! - RETURN + RETURN END SUBROUTINE SET_CSF_ZFlist diff --git a/src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 b/src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 old mode 100755 new mode 100644 index 828dff529..474ccfa70 --- a/src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 +++ b/src/appl/rcsfzerofirst90/set_CSF_ZFlist_I.f90 @@ -1,6 +1,6 @@ - MODULE set_CSF_ZFlist_I + MODULE set_CSF_ZFlist_I INTERFACE SUBROUTINE set_CSF_ZFlist - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rcsfzerofirst90/set_CSF_number.f90 b/src/appl/rcsfzerofirst90/set_CSF_number.f90 old mode 100755 new mode 100644 index 4fb23f4dc..bc5d32225 --- a/src/appl/rcsfzerofirst90/set_CSF_number.f90 +++ b/src/appl/rcsfzerofirst90/set_CSF_number.f90 @@ -42,7 +42,7 @@ SUBROUTINE SET_CSF_number READ (21, '(A2)') S_orbitals ! Read the X, J, and (sign of) P quantum numbers READ (21, '(A2)') S_orbitals - CYCLE + CYCLE END IF EXIT END DO @@ -58,5 +58,5 @@ SUBROUTINE SET_CSF_number ! Peel orbitals READ (21, '(A2)') S_orbitals READ (21, '(1A1)') RECORD - RETURN + RETURN END SUBROUTINE SET_CSF_number diff --git a/src/appl/rcsfzerofirst90/set_CSF_number_I.f90 b/src/appl/rcsfzerofirst90/set_CSF_number_I.f90 old mode 100755 new mode 100644 index 87f615140..aa3d0dd11 --- a/src/appl/rcsfzerofirst90/set_CSF_number_I.f90 +++ b/src/appl/rcsfzerofirst90/set_CSF_number_I.f90 @@ -1,6 +1,6 @@ - MODULE set_CSF_number_I + MODULE set_CSF_number_I INTERFACE - SUBROUTINE set_CSF_number - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE set_CSF_number + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/Makefile b/src/appl/rhfs90/Makefile old mode 100755 new mode 100644 index a7ab2a62d..89a752f6d --- a/src/appl/rhfs90/Makefile +++ b/src/appl/rhfs90/Makefile @@ -9,9 +9,9 @@ MODDIR = ${SRCLIBDIR}/libmod MODL92 = ${SRCLIBDIR}/lib9290 MODLRANG90 = ${SRCLIBDIR}/librang90 MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 +GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} APP_OBJ= opt6_C.o\ getmixblock_I.o rinthf_I.o strsum_I.o \ @@ -23,7 +23,7 @@ APP_OBJ= opt6_C.o\ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ -I $(MODDIR) -o $@ @@ -33,4 +33,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rhfs90/engouth.f90 b/src/appl/rhfs90/engouth.f90 index c500a3f5c..6a5f6f1c1 100644 --- a/src/appl/rhfs90/engouth.f90 +++ b/src/appl/rhfs90/engouth.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUTH(EAV, E, JTOT, IPAR, ILEV, NN, MODE) + SUBROUTINE ENGOUTH(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,94 +13,94 @@ SUBROUTINE ENGOUTH(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: aucm, auev, ccms, fasi, fbsi USE jlabl_C, LABJ=> JLBR, LABP=>JLBP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - REAL(DOUBLE), INTENT(IN) :: EAV - INTEGER, INTENT(IN) :: JTOT(NN) - INTEGER, INTENT(IN) :: IPAR(NN) - INTEGER, INTENT(IN) :: ILEV(NN) - REAL(DOUBLE), INTENT(IN) :: E(NN) + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + REAL(DOUBLE), INTENT(IN) :: EAV + INTEGER, INTENT(IN) :: JTOT(NN) + INTEGER, INTENT(IN) :: IPAR(NN) + INTEGER, INTENT(IN) :: ILEV(NN) + REAL(DOUBLE), INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - WRITE (29, 300) - WRITE (29, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - WRITE (29, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO + WRITE (24, 300) + WRITE (24, 301) + WRITE (29, 300) + WRITE (29, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + WRITE (29, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - WRITE (29, 303) - WRITE (29, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + WRITE (29, 303) + WRITE (29, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV WRITE (29, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - WRITE (29, 304) - WRITE (29, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + WRITE (29, 304) + WRITE (29, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV WRITE (29, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + END DO + ENDIF ! - ENDIF + ENDIF ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,2X,2A4,1P,3D22.14) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,2X,2A4,1P,3D22.14) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUTH + END SUBROUTINE ENGOUTH diff --git a/src/appl/rhfs90/engouth_I.f90 b/src/appl/rhfs90/engouth_I.f90 index 0aabdc61e..cd6c18e2a 100644 --- a/src/appl/rhfs90/engouth_I.f90 +++ b/src/appl/rhfs90/engouth_I.f90 @@ -1,17 +1,17 @@ - MODULE engouth_I + MODULE engouth_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE engouth (EAV, E, JTOT, IPAR, ILEV, NN, MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT - INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE engouth (EAV, E, JTOT, IPAR, ILEV, NN, MODE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT + INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/gethfd.f90 b/src/appl/rhfs90/gethfd.f90 index 87593dbf3..96eb9002e 100644 --- a/src/appl/rhfs90/gethfd.f90 +++ b/src/appl/rhfs90/gethfd.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETHFD(NAME) + SUBROUTINE GETHFD(NAME) ! * ! Interactively determines the data governing the HFS problem. * ! * @@ -10,13 +10,13 @@ SUBROUTINE GETHFD(NAME) ! Written by Farid A. Parpia Last revision: 15 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE decide_C USE def_C @@ -30,12 +30,12 @@ SUBROUTINE GETHFD(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE setqic_I - USE radgrd_I - USE nucpot_I - USE setrwfa_I + USE getyn_I + USE setiso_I + USE setqic_I + USE radgrd_I + USE nucpot_I + USE setrwfa_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -44,109 +44,109 @@ SUBROUTINE GETHFD(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: YES - CHARACTER(LEN=128) :: ISOFILE + LOGICAL :: YES + CHARACTER(LEN=128) :: ISOFILE !----------------------------------------------- ! ! Open, check, load data from, and close the .iso file ! ISOFILE = 'isodata' - CALL SETISO (ISOFILE) + CALL SETISO (ISOFILE) ! ! Determine the physical effects specifications ! - IF (NDEF /= 0) THEN - WRITE (6, *) 'The physical speed of light in' - WRITE (6, *) ' atomic units is', CVAC, ';' - WRITE (6, *) ' revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter the revised value:' - READ (5, *) C - ELSE - C = CVAC - ENDIF - ELSE - C = CVAC - ENDIF -! - IF (NDEF /= 0) THEN -! - WRITE (6, *) 'Treat contributions of some CSFs' - WRITE (6, *) ' as first-order perturbations?' - YES = GETYN() - IF (YES) THEN - LFORDR = .TRUE. - WRITE (6, *) 'The contribution of CSFs' - WRITE (6, *) ' 1 -- ICCUT will be treated' - WRITE (6, *) ' variationally; the remainder' - WRITE (6, *) ' perturbatively; enter ICCUT:' - READ (5, *) ICCUT - ELSE - LFORDR = .FALSE. - ICCUT = 0 - ENDIF - ELSE - LFORDR = .FALSE. - ICCUT = 0 - ENDIF + IF (NDEF /= 0) THEN + WRITE (6, *) 'The physical speed of light in' + WRITE (6, *) ' atomic units is', CVAC, ';' + WRITE (6, *) ' revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter the revised value:' + READ (5, *) C + ELSE + C = CVAC + ENDIF + ELSE + C = CVAC + ENDIF +! + IF (NDEF /= 0) THEN +! + WRITE (6, *) 'Treat contributions of some CSFs' + WRITE (6, *) ' as first-order perturbations?' + YES = GETYN() + IF (YES) THEN + LFORDR = .TRUE. + WRITE (6, *) 'The contribution of CSFs' + WRITE (6, *) ' 1 -- ICCUT will be treated' + WRITE (6, *) ' variationally; the remainder' + WRITE (6, *) ' perturbatively; enter ICCUT:' + READ (5, *) ICCUT + ELSE + LFORDR = .FALSE. + ICCUT = 0 + ENDIF + ELSE + LFORDR = .FALSE. + ICCUT = 0 + ENDIF ! ! Determine the parameters controlling the radial grid ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF .. should be Z-dependent RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF - ENDIF + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Generate $- r \times V_nuc (r)$ ! - CALL NUCPOT + CALL NUCPOT ! ! Load the radial wavefunctions ! ! CALL SETRWFA(NAME) - - CALL SETRWFA (TRIM(NAME)//'.w') - + + CALL SETRWFA (TRIM(NAME)//'.w') + ! - RETURN - END SUBROUTINE GETHFD + RETURN + END SUBROUTINE GETHFD diff --git a/src/appl/rhfs90/gethfd_I.f90 b/src/appl/rhfs90/gethfd_I.f90 index f6dce5acc..1b43489a3 100644 --- a/src/appl/rhfs90/gethfd_I.f90 +++ b/src/appl/rhfs90/gethfd_I.f90 @@ -1,10 +1,10 @@ - MODULE gethfd_I + MODULE gethfd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE gethfd (NAME) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE gethfd (NAME) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/getmixblock.f90 b/src/appl/rhfs90/getmixblock.f90 index cbd36916b..529ce3c0c 100644 --- a/src/appl/rhfs90/getmixblock.f90 +++ b/src/appl/rhfs90/getmixblock.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETMIXBLOCK(NAME, NCI) + SUBROUTINE GETMIXBLOCK(NAME, NCI) ! ! Reads mixing coefficient file from block-structured format ! @@ -12,16 +12,16 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! written by Per Jonsson, September 2003 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE def_C - USE EIGV_C + USE EIGV_C USE orb_C USE prnt_C USE syma_C @@ -29,70 +29,70 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCI + INTEGER, INTENT(IN) :: NCI CHARACTER(LEN=24), INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: K, IERR, IOS, NCFTOT, NVECTOT, NVECSIZ, NBLOCK, I, NVECPAT, & - NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J - REAL(DOUBLE) :: EAVSUM - CHARACTER :: FILNAM*256, FORM*11, G92MIX*6, STATUS*3 + NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J + REAL(DOUBLE) :: EAVSUM + CHARACTER :: FILNAM*256, FORM*11, G92MIX*6, STATUS*3 !----------------------------------------------- ! ! The .mix file is UNFORMATTED; it must exist ! - K = INDEX(NAME,' ') - IF (NCI == 0) THEN - FILNAM = NAME(1:K-1)//'.cm' - ELSE - FILNAM = NAME(1:K-1)//'.m' - ENDIF - FORM = 'UNFORMATTED' - STATUS = 'OLD' + K = INDEX(NAME,' ') + IF (NCI == 0) THEN + FILNAM = NAME(1:K-1)//'.cm' + ELSE + FILNAM = NAME(1:K-1)//'.m' + ENDIF + FORM = 'UNFORMATTED' + STATUS = 'OLD' ! - CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (ISTDE, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (ISTDE, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the header of the file; if not as expected, try again ! - READ (25, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' - CLOSE(25) - STOP - ENDIF - - READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - WRITE (*, *) ' nelec = ', NELEC - WRITE (*, *) ' ncftot = ', NCFTOT - WRITE (*, *) ' nw = ', NW - WRITE (*, *) ' nblock = ', NBLOCK - WRITE (*, *) - + READ (25, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' + CLOSE(25) + STOP + ENDIF + + READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + WRITE (*, *) ' nelec = ', NELEC + WRITE (*, *) ' ncftot = ', NCFTOT + WRITE (*, *) ' nw = ', NW + WRITE (*, *) ' nblock = ', NBLOCK + WRITE (*, *) + !*********************************************************************** ! Allocate memory for old format data !*********************************************************************** - - CALL ALLOC (EVAL, NVECTOT, 'EVAL', 'GETMIXBLOCK') - CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', 'GETMIXBLOCK') - CALL ALLOC (IVEC, NVECTOT, 'IVEC', 'GETMIXBLOCK') - CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', 'GETMIXBLOCK') - CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', 'GETMIXBLOCK') - + + CALL ALLOC (EVAL, NVECTOT, 'EVAL', 'GETMIXBLOCK') + CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', 'GETMIXBLOCK') + CALL ALLOC (IVEC, NVECTOT, 'IVEC', 'GETMIXBLOCK') + CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', 'GETMIXBLOCK') + CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', 'GETMIXBLOCK') + !*********************************************************************** ! Initialize mixing coefficients to zero; others are fine !*********************************************************************** - EVEC(:NVECTOT*NCFTOT) = 0.D0 - + EVEC(:NVECTOT*NCFTOT) = 0.D0 + !*********************************************************************** ! Initialize counters and sum registers ! @@ -103,62 +103,62 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! at least one eigenstate is calculated ! neavsum: total number CSF contributing to eavsum !*********************************************************************** - - NVECPAT = 0 - NCFPAT = 0 - NVECSIZPAT = 0 - NEAVSUM = 0 - EAVSUM = 0.D0 - - WRITE (*, *) ' block ncf nev 2j+1 parity' - DO JB = 1, NBLOCK - - READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA - WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA - IF (JB /= NB) STOP 'jb .NE. nb' - - IF (NEVBLK > 0) THEN - - READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) + + NVECPAT = 0 + NCFPAT = 0 + NVECSIZPAT = 0 + NEAVSUM = 0 + EAVSUM = 0.D0 + + WRITE (*, *) ' block ncf nev 2j+1 parity' + DO JB = 1, NBLOCK + + READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA + WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA + IF (JB /= NB) STOP 'jb .NE. nb' + + IF (NEVBLK > 0) THEN + + READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) ! ivec(i) = ivec(i) + ncfpat ! serial # of the state - IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP - IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA - - READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) - + IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP + IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA + + READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) + ! ...Construct the true energy by adding up the average EVAL(NVECPAT+1:NEVBLK+NVECPAT) = EVAL(NVECPAT+1:NEVBLK+NVECPAT) + & - EAV + EAV ! ...For overal (all blocks) average energy - EAVSUM = EAVSUM + EAV*NCFBLK - NEAVSUM = NEAVSUM + NCFBLK - + EAVSUM = EAVSUM + EAV*NCFBLK + NEAVSUM = NEAVSUM + NCFBLK + READ (25) ((EVEC(NVECSIZPAT+NCFPAT+I+(J-1)*NCFTOT),I=1,NCFBLK),J=1,& - NEVBLK) - ENDIF - - NVECPAT = NVECPAT + NEVBLK - NCFPAT = NCFPAT + NCFBLK - NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT - - END DO - + NEVBLK) + ENDIF + + NVECPAT = NVECPAT + NEVBLK + NCFPAT = NCFPAT + NCFBLK + NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT + + END DO + ! ...Here eav is the average energy of the blocks where at least ! one eigenstate is calculated. It is not the averge of the ! total Hamiltonian. - - EAV = EAVSUM/NEAVSUM - + + EAV = EAVSUM/NEAVSUM + IF (NCFTOT /= NEAVSUM) WRITE (6, *) & 'Not all blocks are diagonalized --- Average E ', 'not correct' - + ! ...Substrct the overal average energy - EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV - - CLOSE(25) - - NCF = NCFTOT - NVEC = NVECTOT - - RETURN - END SUBROUTINE GETMIXBLOCK + EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV + + CLOSE(25) + + NCF = NCFTOT + NVEC = NVECTOT + + RETURN + END SUBROUTINE GETMIXBLOCK diff --git a/src/appl/rhfs90/getmixblock_I.f90 b/src/appl/rhfs90/getmixblock_I.f90 index c4ba56379..44f5a95f8 100644 --- a/src/appl/rhfs90/getmixblock_I.f90 +++ b/src/appl/rhfs90/getmixblock_I.f90 @@ -1,11 +1,11 @@ - MODULE getmixblock_I + MODULE getmixblock_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:32:57 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE getmixblock (NAME, NCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getmixblock (NAME, NCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/hfs92.f90 b/src/appl/rhfs90/hfs92.f90 index 6c582eb1f..2fd4a2d13 100644 --- a/src/appl/rhfs90/hfs92.f90 +++ b/src/appl/rhfs90/hfs92.f90 @@ -40,7 +40,7 @@ !*********************************************************************** !*********************************************************************** !*********************************************************************** - PROGRAM HFS92 + PROGRAM HFS92 ! * ! Entry routine for HFS92. Controls the entire computation. * ! * @@ -54,8 +54,8 @@ PROGRAM HFS92 ! Last revision: Nov 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- ! M o d u l e s @@ -66,111 +66,111 @@ PROGRAM HFS92 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setcsla_I - USE gethfd_I - USE getmixblock_I - USE strsum_I - USE factt_I - USE hfsgg_I + USE getyn_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setcsla_I + USE gethfd_I + USE getmixblock_I + USE strsum_I + USE factt_I + USE hfsgg_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, NCI, NCORE_NOT_USED - LOGICAL :: YES - CHARACTER :: NAME*24 + INTEGER :: K, NCI, NCORE_NOT_USED + LOGICAL :: YES + CHARACTER :: NAME*24 !----------------------------------------------- ! - - WRITE (ISTDE, *) + + WRITE (ISTDE, *) WRITE (ISTDE, *) 'RHFS' WRITE (ISTDE, *) 'This is the hyperfine structure program' WRITE (ISTDE, *) 'Input files: isodata, name.c, name.(c)m, name.w' WRITE (ISTDE, *) 'Output files: name.(c)h, name.(c)hoffd' - - WRITE (ISTDE, *) - WRITE (ISTDE, *) 'Default settings?' - YES = GETYN() - WRITE (ISTDE, *) - IF (YES) THEN - NDEF = 0 - ELSE - NDEF = 1 - ENDIF - - 10 CONTINUE - WRITE (ISTDE, *) 'Name of state' - READ (*, '(A)') NAME - K = INDEX(NAME,' ') - IF (K == 1) THEN - WRITE (ISTDE, *) 'Names may not start with a blank' - GO TO 10 - ENDIF - WRITE (ISTDE, *) - WRITE (ISTDE, *) 'Mixing coefficients from a CI calc.?' - YES = GETYN() - IF (YES) THEN - NCI = 0 - ELSE - NCI = 1 - ENDIF + + WRITE (ISTDE, *) + WRITE (ISTDE, *) 'Default settings?' + YES = GETYN() + WRITE (ISTDE, *) + IF (YES) THEN + NDEF = 0 + ELSE + NDEF = 1 + ENDIF + + 10 CONTINUE + WRITE (ISTDE, *) 'Name of state' + READ (*, '(A)') NAME + K = INDEX(NAME,' ') + IF (K == 1) THEN + WRITE (ISTDE, *) 'Names may not start with a blank' + GO TO 10 + ENDIF + WRITE (ISTDE, *) + WRITE (ISTDE, *) 'Mixing coefficients from a CI calc.?' + YES = GETYN() + IF (YES) THEN + NCI = 0 + ELSE + NCI = 1 + ENDIF ! ! Check compatibility of plant substitutions ! -!GG CALL CHKPLT +!GG CALL CHKPLT ! ! Determine if there is to be any debug printout; this will be ! made on the .dbg file ! - CALL SETDBG + CALL SETDBG ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Open the .sum file ! - CALL SETSUM (NAME, NCI) + CALL SETSUM (NAME, NCI) ! ! Open, check, load data from, and close, the .csl file ! - CALL SETCSLA (NAME, NCORE_NOT_USED) + CALL SETCSLA (NAME, NCORE_NOT_USED) ! ! Get the remaining information ! - CALL GETHFD (NAME) + CALL GETHFD (NAME) ! ! Get the eigenvectors ! -!GG WRITE (ISTDE, *) 'Block format?' -!GG YES = GETYN() -!GG WRITE (ISTDE, *) -!GG IF (YES) THEN - CALL GETMIXBLOCK (NAME, NCI) -!GG ELSE -!GG IF (NCI == 0) THEN -!GG CALL GETMIXC (NAME) -!GG ELSE -!GG CALL GETMIXA (NAME) -!GG ENDIF -!GG ENDIF +!GG WRITE (ISTDE, *) 'Block format?' +!GG YES = GETYN() +!GG WRITE (ISTDE, *) +!GG IF (YES) THEN + CALL GETMIXBLOCK (NAME, NCI) +!GG ELSE +!GG IF (NCI == 0) THEN +!GG CALL GETMIXC (NAME) +!GG ELSE +!GG CALL GETMIXA (NAME) +!GG ENDIF +!GG ENDIF ! ! Append a summary of the inputs to the .sum file ! - CALL STRSUM + CALL STRSUM ! ! Set up the table of logarithms of factorials ! - CALL FACTT + CALL FACTT ! ! Proceed with the HFS calculation ! @@ -178,8 +178,8 @@ PROGRAM HFS92 ! ! Print completion message ! - WRITE (ISTDE, *) - WRITE (ISTDE, *) 'RHFS: Execution complete.' + WRITE (ISTDE, *) + WRITE (ISTDE, *) 'RHFS: Execution complete.' ! - STOP - END PROGRAM HFS92 + STOP + END PROGRAM HFS92 diff --git a/src/appl/rhfs90/hfsgg.f90 b/src/appl/rhfs90/hfsgg.f90 index 10b297881..3e27e1fa9 100644 --- a/src/appl/rhfs90/hfsgg.f90 +++ b/src/appl/rhfs90/hfsgg.f90 @@ -18,60 +18,60 @@ SUBROUTINE HFSGG ! Last revision: Nov 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:35:13 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:35:13 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE decide_C USE DEF_C, ONLY: AUMAMU, CVAC, EMPAM, RBCM, AUCM, & CCMS, B1=>AUMAMU - USE EIGV_C + USE EIGV_C USE foparm_C USE jlabl_C, LABJ=>JLBR, LABP=>JLBP USE nsmdat_C, ONLY: SQN, DMOMNM, QMOMB, & HFSI=>SQN, HFSD=>DMOMNM, HFSQ=>QMOMB USE orb_C USE prnt_C - USE OPT6_C + USE OPT6_C USE syma_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rinthf_I - USE rint_I - USE matelt_I - USE convrt_I - USE ispar_I - USE itjpo_I - USE oneparticlejj_I - USE gracah1_I + USE rinthf_I + USE rint_I + USE matelt_I + USE convrt_I + USE ispar_I + USE itjpo_I + USE oneparticlejj_I + USE gracah1_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 + REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: FFMIN, FFMAX, FF, I, J, KT, IPT, IC, LCNUM, IR, ISPARC, ITJPOC& , ITJPOR, IDIFF, IA, IB, K, KK, LOC1, LOC2, II, JJ, JJII, JB, JA, JJB& - , JJA, IFLAG - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL - REAL(DOUBLE), DIMENSION(2,NNNW,NNNW) :: RINTME, AMELT - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: RINTGJ, RINTDGJ, GJMELT, DGJMELT + , JJA, IFLAG + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + REAL(DOUBLE), DIMENSION(2,NNNW,NNNW) :: RINTME, AMELT + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: RINTGJ, RINTDGJ, GJMELT, DGJMELT ! .. Local pointer arrays REAL(DOUBLE), DIMENSION(:,:), pointer :: HFC REAL(DOUBLE), DIMENSION(:), pointer :: GJC, DGJC REAL(DOUBLE) :: APART, GJPART, DGJPART, ELEMNT, ELEMNTGJ, ELEMNTDGJ,& CONTR, CONTRGJ, CONTRDGJ, AUMHZ, BARNAU, DNMAU, GFAC, HFAC, FJ, & GJA1, AFA1, AFA2, BFA1, BFA2, BFA3, GJ, DGJ, TILDE1, & - TILDE2, FACTOR1, FACTOR2, RAC1, RAC2, HFSELT1, HFSELT2 - CHARACTER :: CNUM*11 + TILDE2, FACTOR1, FACTOR2, RAC1, RAC2, HFSELT1, HFSELT2 + CHARACTER :: CNUM*11 !----------------------------------------------- ! ! @@ -80,78 +80,78 @@ SUBROUTINE HFSGG ! ! Allocate storage for local arrays ! - CALL ALLOC (HFC, 5, NVEC*NVEC, 'HFC', 'HFS') - CALL ALLOC (GJC, NVEC*NVEC, 'GJC', 'HFS') - CALL ALLOC (DGJC, NVEC*NVEC, 'DGLC', 'HFS') + CALL ALLOC (HFC, 5, NVEC*NVEC, 'HFC', 'HFS') + CALL ALLOC (GJC, NVEC*NVEC, 'GJC', 'HFS') + CALL ALLOC (DGJC, NVEC*NVEC, 'DGLC', 'HFS') ! ! Initialise ! - HFC(:,:NVEC*NVEC) = 0.0D00 + HFC(:,:NVEC*NVEC) = 0.0D00 ! - GJC(:NVEC*NVEC) = 0.0D00 - DGJC(:NVEC*NVEC) = 0.0D00 - + GJC(:NVEC*NVEC) = 0.0D00 + DGJC(:NVEC*NVEC) = 0.0D00 + ! ! Calculate and save the radial integrals and angular ! matrix elements for the two multipolarities ! - DO KT = 1, 2 - DO I = 1, NW - DO J = 1, NW - IF (KT == 1) THEN - RINTME(KT,I,J) = RINTHF(I,J,-2) - RINTGJ(I,J) = RINTHF(I,J,1) - ELSE - RINTME(KT,I,J) = RINT(I,J,-3) - RINTDGJ(I,J) = RINT(I,J,0) - ENDIF - CALL MATELT (I, KT, J, APART, GJPART, DGJPART) - AMELT(KT,I,J) = APART - IF (KT /= 1) CYCLE - GJMELT(I,J) = GJPART - DGJMELT(I,J) = DGJPART - END DO - END DO - END DO + DO KT = 1, 2 + DO I = 1, NW + DO J = 1, NW + IF (KT == 1) THEN + RINTME(KT,I,J) = RINTHF(I,J,-2) + RINTGJ(I,J) = RINTHF(I,J,1) + ELSE + RINTME(KT,I,J) = RINT(I,J,-3) + RINTDGJ(I,J) = RINT(I,J,0) + ENDIF + CALL MATELT (I, KT, J, APART, GJPART, DGJPART) + AMELT(KT,I,J) = APART + IF (KT /= 1) CYCLE + GJMELT(I,J) = GJPART + DGJMELT(I,J) = DGJPART + END DO + END DO + END DO ! ! Set the parity of the one-body operators ! - IPT = 1 + IPT = 1 ! ! Sweep through the Hamiltonian matrix to determine the ! diagonal and off-diagonal hyperfine constants ! - DO IC = 1, NCF + DO IC = 1, NCF ! ! Output IC on the screen to show how far the calculation has preceede ! - IF (MOD(IC,100) == 0) THEN - CALL CONVRT (IC, CNUM, LCNUM) - WRITE (6, *) 'Column '//CNUM(1:LCNUM)//' complete;' - ENDIF + IF (MOD(IC,100) == 0) THEN + CALL CONVRT (IC, CNUM, LCNUM) + WRITE (6, *) 'Column '//CNUM(1:LCNUM)//' complete;' + ENDIF ! - DO IR = 1, NCF + DO IR = 1, NCF ! ! If LFORDR is .TRUE., a `first order' calculation is indicated; ! only the CSFs with serial numbers exceeding IC are treated specially ! only diagonal elements are evaluated for the `first order' CSFs ! - IF (LFORDR .AND. IC>ICCUT .AND. IC/=IR) CYCLE + IF (LFORDR .AND. IC>ICCUT .AND. IC/=IR) CYCLE ! - ISPARC = ISPAR(IC) - ITJPOC = ITJPO(IC) - ITJPOR = ITJPO(IR) - IDIFF = ITJPOC - ITJPOR + ISPARC = ISPAR(IC) + ITJPOC = ITJPO(IC) + ITJPOR = ITJPO(IR) + IDIFF = ITJPOC - ITJPOR ! ! Loop over the multipolarities ! - DO KT = 1, 2 + DO KT = 1, 2 ! ! Initialise the accumulator ! - ELEMNT = 0.0D00 - ELEMNTGJ = 0.0D00 - ELEMNTDGJ = 0.0D00 + ELEMNT = 0.0D00 + ELEMNTGJ = 0.0D00 + ELEMNTDGJ = 0.0D00 ! ! Consider 3 cases ! (k) @@ -164,299 +164,299 @@ SUBROUTINE HFSGG ! (3) < J || T || J-2 > , k = 2 ! IF (.NOT.(IDIFF==0 .AND. IR>=IC .OR. IDIFF==2 .OR. IDIFF==4& - .AND. KT==2)) CYCLE + .AND. KT==2)) CYCLE ! CALL ONEPARTICLEJJ(KT,IPT,IC,IR,IA,IB,TSHELL) -!GG CALL TNSRJJ (KT, IPT, IC, IR, IA, IB, TSHELL) +!GG CALL TNSRJJ (KT, IPT, IC, IR, IA, IB, TSHELL) ! ! Accumulate the contribution from the one-body operators; ! - IF (IA /= 0) THEN - IF (IA == IB) THEN - IF (KT/=1 .OR. IDIFF/=0) THEN - DO IA = 1, NW - IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE + IF (IA /= 0) THEN + IF (IA == IB) THEN + IF (KT/=1 .OR. IDIFF/=0) THEN + DO IA = 1, NW + IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE ELEMNT = ELEMNT + AMELT(KT,IA,IA)*RINTME(KT,IA,IA)*& - TSHELL(IA) - CYCLE - END DO - ELSE - DO IA = 1, NW - IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE + TSHELL(IA) + CYCLE + END DO + ELSE + DO IA = 1, NW + IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE ELEMNT = ELEMNT + AMELT(KT,IA,IA)*RINTME(KT,IA,IA)*& - TSHELL(IA) + TSHELL(IA) ELEMNTGJ = ELEMNTGJ + GJMELT(IA,IA)*RINTGJ(IA,IA)*& - TSHELL(IA) + TSHELL(IA) ELEMNTDGJ = ELEMNTDGJ + DGJMELT(IA,IA)*RINTDGJ(IA,IA& - )*TSHELL(IA) - END DO - ENDIF - ELSE - IF (ABS(TSHELL(1)) > CUTOFF) THEN + )*TSHELL(IA) + END DO + ENDIF + ELSE + IF (ABS(TSHELL(1)) > CUTOFF) THEN ELEMNT = ELEMNT + AMELT(KT,IA,IB)*RINTME(KT,IA,IB)*& - TSHELL(1) - IF (KT==1 .AND. IDIFF==0) THEN + TSHELL(1) + IF (KT==1 .AND. IDIFF==0) THEN ELEMNTGJ = ELEMNTGJ + GJMELT(IA,IB)*RINTGJ(IA,IB)*& - TSHELL(1) + TSHELL(1) ELEMNTDGJ = ELEMNTDGJ + DGJMELT(IA,IB)*RINTDGJ(IA,IB& - )*TSHELL(1) - ENDIF - ENDIF - ENDIF - ENDIF + )*TSHELL(1) + ENDIF + ENDIF + ENDIF + ENDIF ! ! Multiply with the configuration expansion coefficients and add the ! contributions from the matrix elements to obtain total contributions ! - DO K = 1, NVEC - DO KK = 1, NVEC - LOC1 = (K - 1)*NCF - LOC2 = (KK - 1)*NCF - IF (IDIFF==0 .AND. IR/=IC) THEN + DO K = 1, NVEC + DO KK = 1, NVEC + LOC1 = (K - 1)*NCF + LOC2 = (KK - 1)*NCF + IF (IDIFF==0 .AND. IR/=IC) THEN CONTR = ELEMNT*(EVEC(IC + LOC1)*EVEC(IR + LOC2) + EVEC(& - IR + LOC1)*EVEC(IC + LOC2)) + IR + LOC1)*EVEC(IC + LOC2)) CONTRGJ = ELEMNTGJ*(EVEC(IC + LOC1)*EVEC(IR + LOC2) + & - EVEC(IR + LOC1)*EVEC(IC + LOC2)) + EVEC(IR + LOC1)*EVEC(IC + LOC2)) CONTRDGJ = ELEMNTDGJ*(EVEC(IC + LOC1)*EVEC(IR + LOC2)& - + EVEC(IR + LOC1)*EVEC(IC + LOC2)) - ELSE - CONTR = ELEMNT*EVEC(IC + LOC1)*EVEC(IR + LOC2) - CONTRGJ = ELEMNTGJ*EVEC(IC + LOC1)*EVEC(IR + LOC2) - CONTRDGJ = ELEMNTDGJ*EVEC(IC + LOC1)*EVEC(IR + LOC2) - ENDIF + + EVEC(IR + LOC1)*EVEC(IC + LOC2)) + ELSE + CONTR = ELEMNT*EVEC(IC + LOC1)*EVEC(IR + LOC2) + CONTRGJ = ELEMNTGJ*EVEC(IC + LOC1)*EVEC(IR + LOC2) + CONTRDGJ = ELEMNTDGJ*EVEC(IC + LOC1)*EVEC(IR + LOC2) + ENDIF ! ! Magnetic dipole and the two operators of the g_j factor ! - IF (KT == 1) THEN - IF (IDIFF == 0) THEN - HFC(1,NVEC*(K-1)+KK) = HFC(1,NVEC*(K-1)+KK) + CONTR - GJC(NVEC*(K-1)+KK) = GJC(NVEC*(K-1)+KK) + CONTRGJ - DGJC(NVEC*(K-1)+KK) = DGJC(NVEC*(K-1)+KK) + CONTRDGJ - ELSE IF (ITJPOC - ITJPOR == 2) THEN - HFC(2,NVEC*(K-1)+KK) = HFC(2,NVEC*(K-1)+KK) + CONTR - ENDIF + IF (KT == 1) THEN + IF (IDIFF == 0) THEN + HFC(1,NVEC*(K-1)+KK) = HFC(1,NVEC*(K-1)+KK) + CONTR + GJC(NVEC*(K-1)+KK) = GJC(NVEC*(K-1)+KK) + CONTRGJ + DGJC(NVEC*(K-1)+KK) = DGJC(NVEC*(K-1)+KK) + CONTRDGJ + ELSE IF (ITJPOC - ITJPOR == 2) THEN + HFC(2,NVEC*(K-1)+KK) = HFC(2,NVEC*(K-1)+KK) + CONTR + ENDIF ! ! Electric quadrupole ! - ELSE IF (KT == 2) THEN - SELECT CASE (IDIFF) - CASE (0) - HFC(3,NVEC*(K-1)+KK) = HFC(3,NVEC*(K-1)+KK) + CONTR - CASE (2) - HFC(4,NVEC*(K-1)+KK) = HFC(4,NVEC*(K-1)+KK) + CONTR - CASE (4) - HFC(5,NVEC*(K-1)+KK) = HFC(5,NVEC*(K-1)+KK) + CONTR - END SELECT - ENDIF - END DO - END DO + ELSE IF (KT == 2) THEN + SELECT CASE (IDIFF) + CASE (0) + HFC(3,NVEC*(K-1)+KK) = HFC(3,NVEC*(K-1)+KK) + CONTR + CASE (2) + HFC(4,NVEC*(K-1)+KK) = HFC(4,NVEC*(K-1)+KK) + CONTR + CASE (4) + HFC(5,NVEC*(K-1)+KK) = HFC(5,NVEC*(K-1)+KK) + CONTR + END SELECT + ENDIF + END DO + END DO ! - END DO + END DO ! - END DO - END DO + END DO + END DO ! ! These are the conversion factors to obtain the hyperfine ! constants in MHz ! - AUMHZ = AUCM*CCMS*1.0D-06 - BARNAU = 1.0D-24/RBCM**2 - DNMAU = B1/(2.0D00*CVAC*EMPAM) + AUMHZ = AUCM*CCMS*1.0D-06 + BARNAU = 1.0D-24/RBCM**2 + DNMAU = B1/(2.0D00*CVAC*EMPAM) ! - GFAC = AUMHZ*DNMAU*HFSD/HFSI - HFAC = AUMHZ*2.0D00*HFSQ*BARNAU + GFAC = AUMHZ*DNMAU*HFSD/HFSI + HFAC = AUMHZ*2.0D00*HFSQ*BARNAU ! ! Output the hyperfine interaction constants ! - WRITE (24, 302) - WRITE (29, 402) + WRITE (24, 302) + WRITE (29, 402) ! - DO I = 1, NVEC - DO II = 1, NVEC + DO I = 1, NVEC + DO II = 1, NVEC ! - JJ = IATJPO(I) - JJII = IATJPO(II) + JJ = IATJPO(I) + JJII = IATJPO(II) ! - IF (.NOT.(JJ==JJII .AND. JJII>1 .OR. JJ>JJII)) CYCLE + IF (.NOT.(JJ==JJII .AND. JJII>1 .OR. JJ>JJII)) CYCLE ! - FJ = 0.5D00*DBLE(JJ - 1) + FJ = 0.5D00*DBLE(JJ - 1) ! - GJA1 = SQRT(1.0D00/(FJ*(FJ + 1.0D00))) - - AFA1 = GFAC*GJA1 - - IF (JJ == 2) THEN - AFA2 = 0.D000 - ELSE - AFA2 = GFAC*SQRT(1.0D00/(FJ*(2.0D00*FJ - 1.0D00))) - ENDIF + GJA1 = SQRT(1.0D00/(FJ*(FJ + 1.0D00))) + + AFA1 = GFAC*GJA1 + + IF (JJ == 2) THEN + AFA2 = 0.D000 + ELSE + AFA2 = GFAC*SQRT(1.0D00/(FJ*(2.0D00*FJ - 1.0D00))) + ENDIF BFA1 = HFAC*SQRT((FJ*(2.0D00*FJ - 1.0D00))/((FJ + 1.0D00)*(2.0D00*& - FJ + 3.0D00))) - IF (JJ == 2) THEN - BFA2 = 0.0D00 - ELSE + FJ + 3.0D00))) + IF (JJ == 2) THEN + BFA2 = 0.0D00 + ELSE BFA2 = 0.25D00*HFAC*SQRT((FJ*(FJ - 1.0D00))/((FJ + 1.0D00)*(& - 2.0D00*FJ - 1.0D00))) - ENDIF - IF (JJ == 4) THEN - BFA3 = 0.0D00 - ELSE + 2.0D00*FJ - 1.0D00))) + ENDIF + IF (JJ == 4) THEN + BFA3 = 0.0D00 + ELSE BFA3 = 0.125D00*HFAC*SQRT((FJ*(FJ - 1.0D000)*(2.0D00*FJ - 1.0D00& - ))/(2.0D00*FJ - 3.0D00)) - ENDIF + ))/(2.0D00*FJ - 3.0D00)) + ENDIF ! ! Diagonal (J,J) A and B factors ! - SELECT CASE (JJ - JJII) - CASE (0) - IF (I <= II) THEN + SELECT CASE (JJ - JJII) + CASE (0) + IF (I <= II) THEN ! GJ = CVAC*GJA1*GJC(NVEC*(I-1)+II) ! DGJ = 0.001160D0*GJA1*DGJC(NVEC*(I-1)+II) WRITE (24, 303) IVEC(I), LABJ(JJ), LABP((IASPAR(I)+3)/2), & IVEC(II), LABJ(JJII), LABP((IASPAR(II)+3)/2), AFA1*HFC(1,& - NVEC*(I-1)+II), BFA1*HFC(3,NVEC*(I-1)+II) + NVEC*(I-1)+II), BFA1*HFC(3,NVEC*(I-1)+II) ! ! Output diagonal hfs and g_j factors to file .h or .ch ! - IF (I == II) THEN - GJ = CVAC*GJA1*GJC(NVEC*(I-1)+II) - DGJ = 0.001160D0*GJA1*DGJC(NVEC*(I-1)+II) + IF (I == II) THEN + GJ = CVAC*GJA1*GJC(NVEC*(I-1)+II) + DGJ = 0.001160D0*GJA1*DGJC(NVEC*(I-1)+II) WRITE (29, 403) IVEC(I), LABJ(JJ), LABP((IASPAR(I)+3)/2), & AFA1*HFC(1,NVEC*(I-1)+II), BFA1*HFC(3,NVEC*(I-1)+II), & - GJ, DGJ, GJ + DGJ - ENDIF - ENDIF + GJ, DGJ, GJ + DGJ + ENDIF + ENDIF ! ! Off diagonal (J,J-1) A and B factors ! - CASE (2) + CASE (2) WRITE (24, 303) IVEC(I), LABJ(JJ), LABP((IASPAR(I)+3)/2), IVEC(& II), LABJ(JJII), LABP((IASPAR(II)+3)/2), AFA2*HFC(2,NVEC*(I-1& - )+II), BFA2*HFC(4,NVEC*(I-1)+II) + )+II), BFA2*HFC(4,NVEC*(I-1)+II) ! ! Off diagonal (J,J-2) B factor ! - CASE (4) + CASE (4) WRITE (24, 303) IVEC(I), LABJ(JJ), LABP((IASPAR(I)+3)/2), IVEC(& II), LABJ(JJII), LABP((IASPAR(II)+3)/2), 0.0D00, BFA3*HFC(5,& - NVEC*(I-1)+II) - END SELECT + NVEC*(I-1)+II) + END SELECT ! - END DO - END DO + END DO + END DO ! ! These are the factors needed to obtain the F-dependent hyperfine ! matrix elements in Hartrees ! - TILDE1 = SQRT((HFSI + 1.0D00)/HFSI)*HFSD*0.5D00*B1/(EMPAM*CVAC) - IF (HFSI > 0.6D00) THEN + TILDE1 = SQRT((HFSI + 1.0D00)/HFSI)*HFSD*0.5D00*B1/(EMPAM*CVAC) + IF (HFSI > 0.6D00) THEN TILDE2 = SQRT((HFSI + 1.0D00)*(2.0D00*HFSI + 3.D0)/((2.0D00*HFSI - & - 1.0D00)*HFSI)) - TILDE2 = TILDE2*HFSQ*0.5D00*BARNAU - ELSE - TILDE2 = 0.0D00 - ENDIF + 1.0D00)*HFSI)) + TILDE2 = TILDE2*HFSQ*0.5D00*BARNAU + ELSE + TILDE2 = 0.0D00 + ENDIF ! ! II = 2*I ! - II = NINT(2.0D00*HFSI) + II = NINT(2.0D00*HFSI) ! ! Calculate the F-dependent matrix elemnts ! ! Loop over the states ! - DO JB = 1, NVEC - DO JA = 1, NVEC - JJB = IATJPO(JB) - 1 - JJA = IATJPO(JA) - 1 - IF (.NOT.(JJA==JJB .AND. JJA>0 .OR. JJB>JJA)) CYCLE + DO JB = 1, NVEC + DO JA = 1, NVEC + JJB = IATJPO(JB) - 1 + JJA = IATJPO(JA) - 1 + IF (.NOT.(JJA==JJB .AND. JJA>0 .OR. JJB>JJA)) CYCLE ! ! Determine the possible F quantum numbers for the matrix element ! - FFMIN = MAX(ABS(JJA - II),ABS(JJB - II)) - FFMAX = MIN(JJA + II,JJB + II) + FFMIN = MAX(ABS(JJA - II),ABS(JJB - II)) + FFMAX = MIN(JJA + II,JJB + II) ! ! Loop over the possible F quantum numbers ! - IFLAG = 0 - DO FF = FFMIN, FFMAX, 2 + IFLAG = 0 + DO FF = FFMIN, FFMAX, 2 ! ! Phase factor ! - IF (MOD((II + JJA - FF)/2,2) == 1) THEN - FACTOR1 = -1.0D00 - ELSE - FACTOR1 = 1.0D00 - ENDIF - FACTOR2 = FACTOR1*SQRT((DBLE(JJB) + 1.0D00)*(DBLE(II) + 1.0D00)) + IF (MOD((II + JJA - FF)/2,2) == 1) THEN + FACTOR1 = -1.0D00 + ELSE + FACTOR1 = 1.0D00 + ENDIF + FACTOR2 = FACTOR1*SQRT((DBLE(JJB) + 1.0D00)*(DBLE(II) + 1.0D00)) ! ! Determine the Racah W coefficients. ! -!GG CALL DRACAH (II, JJA, II, JJB, FF, 2, RAC1) +!GG CALL DRACAH (II, JJA, II, JJB, FF, 2, RAC1) CALL GRACAH1 (II,JJA,II,JJB,FF,2,RAC1) -!GG CALL DRACAH (II, JJA, II, JJB, FF, 4, RAC2) +!GG CALL DRACAH (II, JJA, II, JJB, FF, 4, RAC2) CALL GRACAH1 (II,JJA,II,JJB,FF,4,RAC2) ! ! Obtain and output matrix elements for J,J ! - IF (JJA - JJB == 0) THEN - HFSELT1 = FACTOR2*RAC1*HFC(1,NVEC*(JB-1)+JA)*TILDE1 - HFSELT2 = FACTOR2*RAC2*HFC(3,NVEC*(JB-1)+JA)*TILDE2 - IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN - IF (IFLAG == 0) WRITE (24, 304) - IFLAG = 1 + IF (JJA - JJB == 0) THEN + HFSELT1 = FACTOR2*RAC1*HFC(1,NVEC*(JB-1)+JA)*TILDE1 + HFSELT2 = FACTOR2*RAC2*HFC(3,NVEC*(JB-1)+JA)*TILDE2 + IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN + IF (IFLAG == 0) WRITE (24, 304) + IFLAG = 1 WRITE (24, 305) IVEC(JB), LABJ(JJB+1), LABP((IASPAR(JB)+3)& /2), IVEC(JA), LABJ(JJA+1), LABP((IASPAR(JA)+3)/2), & - LABJ(FF+1), HFSELT1 + HFSELT2 - ENDIF + LABJ(FF+1), HFSELT1 + HFSELT2 + ENDIF ! ! Obtain and output matrix elements for J,J-1 ! - ELSE IF (ABS(JJA - JJB) == 2) THEN - HFSELT1 = FACTOR2*RAC1*HFC(2,NVEC*(JB-1)+JA)*TILDE1 - HFSELT2 = FACTOR2*RAC2*HFC(4,NVEC*(JB-1)+JA)*TILDE2 - IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN - IF (IFLAG == 0) WRITE (24, 304) - IFLAG = 1 + ELSE IF (ABS(JJA - JJB) == 2) THEN + HFSELT1 = FACTOR2*RAC1*HFC(2,NVEC*(JB-1)+JA)*TILDE1 + HFSELT2 = FACTOR2*RAC2*HFC(4,NVEC*(JB-1)+JA)*TILDE2 + IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN + IF (IFLAG == 0) WRITE (24, 304) + IFLAG = 1 WRITE (24, 305) IVEC(JB), LABJ(JJB+1), LABP((IASPAR(JB)+3)& /2), IVEC(JA), LABJ(JJA+1), LABP((IASPAR(JA)+3)/2), & - LABJ(FF+1), HFSELT1 + HFSELT2 - ENDIF + LABJ(FF+1), HFSELT1 + HFSELT2 + ENDIF ! ! Obtain and output matrix elements for J,J-2 ! - ELSE IF (ABS(JJA - JJB) == 4) THEN - HFSELT1 = 0.0D00 - HFSELT2 = FACTOR2*RAC2*HFC(5,NVEC*(JB-1)+JA)*TILDE2 - IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN - IF (IFLAG == 0) WRITE (24, 304) - IFLAG = 1 + ELSE IF (ABS(JJA - JJB) == 4) THEN + HFSELT1 = 0.0D00 + HFSELT2 = FACTOR2*RAC2*HFC(5,NVEC*(JB-1)+JA)*TILDE2 + IF (ABS(HFSELT1 + HFSELT2) > CUTOFF*10.0D-05) THEN + IF (IFLAG == 0) WRITE (24, 304) + IFLAG = 1 WRITE (24, 305) IVEC(JB), LABJ(JJB+1), LABP((IASPAR(JB)+3)& /2), IVEC(JA), LABJ(JJA+1), LABP((IASPAR(JA)+3)/2), & - LABJ(FF+1), HFSELT1 + HFSELT2 - ENDIF - ELSE - HFSELT1 = 0.0D00 - HFSELT2 = 0.0D00 - ENDIF - END DO - END DO - END DO -! - CALL DALLOC (HFC, 'HFC', 'HFS') - RETURN + LABJ(FF+1), HFSELT1 + HFSELT2 + ENDIF + ELSE + HFSELT1 = 0.0D00 + HFSELT2 = 0.0D00 + ENDIF + END DO + END DO + END DO +! + CALL DALLOC (HFC, 'HFC', 'HFS') + RETURN ! 302 FORMAT(/,/,' Interaction constants:'/,/,& - ' Level1 J Parity Level2 J Parity',8X,'A (MHz)',13X,'B (MHz)'/) + ' Level1 J Parity Level2 J Parity',8X,'A (MHz)',13X,'B (MHz)'/) 402 FORMAT(/,/,' Interaction constants:'/,/,' Level1 J Parity ',8X,'A (MHz)'& - ,13X,'B (MHz)',13X,'g_J',14X,'delta g_J',11X,'total g_J'/) - 303 FORMAT(1X,1I3,5X,2A4,2X,1I3,5X,2A4,1P,2D20.10) - 403 FORMAT(1X,1I3,5X,2A4,1P,5D20.10) + ,13X,'B (MHz)',13X,'g_J',14X,'delta g_J',11X,'total g_J'/) + 303 FORMAT(1X,1I3,5X,2A4,2X,1I3,5X,2A4,1P,2D20.10) + 403 FORMAT(1X,1I3,5X,2A4,1P,5D20.10) 304 FORMAT(/,/,' Matrix elements:'/,/,& ' Level1 J Parity Level2 J Parity F ',4X,'Matrix element (a.u.)'& - /) - 305 FORMAT(1X,1I3,5X,2A4,2X,1I3,5X,2A4,1X,A4,4X,1P,1D20.10) - RETURN + /) + 305 FORMAT(1X,1I3,5X,2A4,2X,1I3,5X,2A4,1X,A4,4X,1P,1D20.10) + RETURN ! END SUBROUTINE HFSGG diff --git a/src/appl/rhfs90/hfsgg_I.f90 b/src/appl/rhfs90/hfsgg_I.f90 index cc00ebb85..0959b05d4 100644 --- a/src/appl/rhfs90/hfsgg_I.f90 +++ b/src/appl/rhfs90/hfsgg_I.f90 @@ -1,9 +1,9 @@ - MODULE hfsgg_I + MODULE hfsgg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:34:47 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:34:47 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE hfsgg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE hfsgg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/matelt.f90 b/src/appl/rhfs90/matelt.f90 index 240735781..0b92039d6 100644 --- a/src/appl/rhfs90/matelt.f90 +++ b/src/appl/rhfs90/matelt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MATELT(I1, K, I2, APART, GJPART, DGJPART) + SUBROUTINE MATELT(I1, K, I2, APART, GJPART, DGJPART) ! * ! This routine computes the angular part of the reduced matrix * ! elements of the magnetic and electric multipole operators as * @@ -11,102 +11,102 @@ SUBROUTINE MATELT(I1, K, I2, APART, GJPART, DGJPART) ! Written by Per Jonsson Last revision: 22 Oct 1999 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE orb_C, ONLY: np, nak !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: I1 - INTEGER :: K - INTEGER, INTENT(IN) :: I2 - REAL(DOUBLE), INTENT(OUT) :: APART - REAL(DOUBLE), INTENT(OUT) :: GJPART - REAL(DOUBLE), INTENT(OUT) :: DGJPART + INTEGER, INTENT(IN) :: I1 + INTEGER :: K + INTEGER, INTENT(IN) :: I2 + REAL(DOUBLE), INTENT(OUT) :: APART + REAL(DOUBLE), INTENT(OUT) :: GJPART + REAL(DOUBLE), INTENT(OUT) :: DGJPART !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KAP1, KAP2, L1, L2 - REAL(DOUBLE) :: FASE, OVLFAC + INTEGER :: KAP1, KAP2, L1, L2 + REAL(DOUBLE) :: FASE, OVLFAC !----------------------------------------------- ! ! ! Set KAP1 and KAP2 ! - KAP1 = NAK(I1) + KAP1 = NAK(I1) ! - IF (MOD(K,2) == 1) THEN - KAP2 = -NAK(I2) - ELSE - KAP2 = NAK(I2) - ENDIF + IF (MOD(K,2) == 1) THEN + KAP2 = -NAK(I2) + ELSE + KAP2 = NAK(I2) + ENDIF ! ! Determine the l quantum numbers ! - IF (KAP1 > 0) THEN - L1 = KAP1 - ELSE - L1 = (-KAP1) - 1 - ENDIF + IF (KAP1 > 0) THEN + L1 = KAP1 + ELSE + L1 = (-KAP1) - 1 + ENDIF ! - IF (KAP2 > 0) THEN - L2 = KAP2 - ELSE - L2 = (-KAP2) - 1 - ENDIF + IF (KAP2 > 0) THEN + L2 = KAP2 + ELSE + L2 = (-KAP2) - 1 + ENDIF ! - IF (MOD(L1 + K + L2,2) == 0) THEN + IF (MOD(L1 + K + L2,2) == 0) THEN ! ! Parity selection rule satisfied ! ! Determine the phase factor ! - IF (MOD(KAP1 + 1,2) == 0) THEN - FASE = 1.0D00 - ELSE - FASE = -1.0D00 - ENDIF + IF (MOD(KAP1 + 1,2) == 0) THEN + FASE = 1.0D00 + ELSE + FASE = -1.0D00 + ENDIF ! ! The other factor is \sqrt (2 j_2 + 1); since j = | \kappa | - 1/2, ! we have 2 j_2 + 1 = 2 | \kappa |; the factor \sqrt (2 j_2 + 1) ! has been accounted for in MCT ! - OVLFAC = FASE*SQRT(DBLE(2*ABS(KAP2))) + OVLFAC = FASE*SQRT(DBLE(2*ABS(KAP2))) ! - IF (MOD(K,2) == 1) THEN + IF (MOD(K,2) == 1) THEN ! ! These are for the magnetic multipole moments and the two operators of the g_j factor ! - APART = (KAP1 + NAK(I2))*CLRX(KAP1,K,KAP2)*OVLFAC + APART = (KAP1 + NAK(I2))*CLRX(KAP1,K,KAP2)*OVLFAC ! - GJPART = APART - DGJPART = -(KAP1 + NAK(I2)-1.0D00)*CLRX(KAP1,K,KAP2)*OVLFAC - ELSE + GJPART = APART + DGJPART = -(KAP1 + NAK(I2)-1.0D00)*CLRX(KAP1,K,KAP2)*OVLFAC + ELSE ! ! These are for the electric multipole moments ! - APART = CLRX(KAP1,K,KAP2)*OVLFAC + APART = CLRX(KAP1,K,KAP2)*OVLFAC ! - ENDIF + ENDIF ! - ELSE + ELSE ! - APART = 0.0D00 - GJPART = 0.0D00 - DGJPART = 0.0D00 + APART = 0.0D00 + GJPART = 0.0D00 + DGJPART = 0.0D00 ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE MATELT + RETURN + END SUBROUTINE MATELT diff --git a/src/appl/rhfs90/matelt_I.f90 b/src/appl/rhfs90/matelt_I.f90 index 99ef556b4..bfa8be4fd 100644 --- a/src/appl/rhfs90/matelt_I.f90 +++ b/src/appl/rhfs90/matelt_I.f90 @@ -1,16 +1,16 @@ - MODULE matelt_I + MODULE matelt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE matelt (I1, K, I2, APART, GJPART, DGJPART) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: I1 - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: I2 - REAL(DOUBLE), INTENT(OUT) :: APART - REAL(DOUBLE), INTENT(OUT) :: GJPART - REAL(DOUBLE), INTENT(OUT) :: DGJPART - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE matelt (I1, K, I2, APART, GJPART, DGJPART) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: I1 + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: I2 + REAL(DOUBLE), INTENT(OUT) :: APART + REAL(DOUBLE), INTENT(OUT) :: GJPART + REAL(DOUBLE), INTENT(OUT) :: DGJPART + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/opt6_C.f90 b/src/appl/rhfs90/opt6_C.f90 index 5bc43e434..51fd173a7 100644 --- a/src/appl/rhfs90/opt6_C.f90 +++ b/src/appl/rhfs90/opt6_C.f90 @@ -1,7 +1,7 @@ - MODULE opt6_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 18:34:47 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE opt6_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 18:34:47 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - INTEGER, DIMENSION(10) :: NTC - END MODULE opt6_C + INTEGER, DIMENSION(10) :: NTC + END MODULE opt6_C diff --git a/src/appl/rhfs90/rinthf.f90 b/src/appl/rhfs90/rinthf.f90 index 8de239337..86b13542e 100644 --- a/src/appl/rhfs90/rinthf.f90 +++ b/src/appl/rhfs90/rinthf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTHF (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINTHF (I, J, K) ! * ! The value of RINTHF is an approximation to: * ! * @@ -16,49 +16,49 @@ REAL(KIND(0.0D0)) FUNCTION RINTHF (I, J, K) ! Written by Per O. Jonsson Last revision: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE tatb_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Tabulate integrand as required for SUBROUTINE QUAD ! - MTP = MIN(MF(I),MF(J)) + MTP = MIN(MF(I),MF(J)) ! ! Value at first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PF(L,I)*QF(L,J) + QF(L,I)*PF(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PF(L,I)*QF(L,J) + QF(L,I)*PF(L,J))*RP(L) + END DO ! ! Perform integration ! - CALL QUAD (RESULT) - RINTHF = RESULT + CALL QUAD (RESULT) + RINTHF = RESULT ! - RETURN - END FUNCTION RINTHF + RETURN + END FUNCTION RINTHF diff --git a/src/appl/rhfs90/rinthf_I.f90 b/src/appl/rhfs90/rinthf_I.f90 index 159264adc..10d83def2 100644 --- a/src/appl/rhfs90/rinthf_I.f90 +++ b/src/appl/rhfs90/rinthf_I.f90 @@ -1,12 +1,12 @@ - MODULE rinthf_I + MODULE rinthf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - REAL(KIND(0.0D0)) FUNCTION rinthf (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rinthf (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/setdbg.f90 b/src/appl/rhfs90/setdbg.f90 index fb3576028..2a8b63e4d 100644 --- a/src/appl/rhfs90/setdbg.f90 +++ b/src/appl/rhfs90/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG + SUBROUTINE SETDBG !----------------------------------------------- ! * ! This subroutine sets the arrays that control debug printout from * @@ -11,8 +11,8 @@ SUBROUTINE SETDBG ! Written by Farid A Parpia Last update: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- ! M o d u l e s @@ -22,96 +22,96 @@ SUBROUTINE SETDBG !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I + USE getyn_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IERR - LOGICAL :: YES - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: I, IERR + LOGICAL :: YES + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! Initialise the arrays that control the debug printout ! - LDBPA = .FALSE. + LDBPA = .FALSE. ! - LDBPG = .FALSE. + LDBPG = .FALSE. ! - LDBPR = .FALSE. + LDBPR = .FALSE. ! - IF (NDEF == 0) RETURN - - WRITE (6, *) 'Generate debug printout?' - YES = GETYN() - IF (YES) THEN + IF (NDEF == 0) RETURN + + WRITE (6, *) 'Generate debug printout?' + YES = GETYN() + IF (YES) THEN ! ! The .dbg file is formatted; open it on unit 99 ! - DEFNAM = 'hfs92.dbg' - FORM = 'FORMATTED' - STATUS = 'NEW' -! - WRITE (6, *) 'File hfs92.dbg will be created as the' - WRITE (6, *) ' HFS92 DeBuG Printout File; enter another' - WRITE (6, *) ' file name if this is not acceptable;' - WRITE (6, *) ' null otherwise:' - READ (*, '(A)') FILNAM -! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM -! - 4 CONTINUE - CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 5 CONTINUE - WRITE (6, *) 'Enter a name for the HFS92 DeBuG Printout' - WRITE (6, *) ' file that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 5 - GO TO 4 - ENDIF + DEFNAM = 'hfs92.dbg' + FORM = 'FORMATTED' + STATUS = 'NEW' +! + WRITE (6, *) 'File hfs92.dbg will be created as the' + WRITE (6, *) ' HFS92 DeBuG Printout File; enter another' + WRITE (6, *) ' file name if this is not acceptable;' + WRITE (6, *) ' null otherwise:' + READ (*, '(A)') FILNAM +! + IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM +! + 4 CONTINUE + CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 5 CONTINUE + WRITE (6, *) 'Enter a name for the HFS92 DeBuG Printout' + WRITE (6, *) ' file that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 5 + GO TO 4 + ENDIF ! ! Set options for general printout ! - WRITE (6, *) ' Print out the machine constants used?' - YES = GETYN() - IF (YES) LDBPG(1) = .TRUE. - WRITE (6, *) ' Print out the physical constants used?' - YES = GETYN() - IF (YES) LDBPG(2) = .TRUE. + WRITE (6, *) ' Print out the machine constants used?' + YES = GETYN() + IF (YES) LDBPG(1) = .TRUE. + WRITE (6, *) ' Print out the physical constants used?' + YES = GETYN() + IF (YES) LDBPG(2) = .TRUE. ! ! Set options for radial modules ! - WRITE (6, *) ' Printout from radial modules?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) ' Printout from RADGRD?' - YES = GETYN() - IF (YES) LDBPR(1) = .TRUE. - WRITE (6, *) ' Printout from NUCPOT?' - YES = GETYN() - IF (YES) LDBPR(2) = .TRUE. - WRITE (6, *) ' Printout from LODRWF?' - YES = GETYN() - IF (YES) LDBPR(3) = .TRUE. -! - ENDIF + WRITE (6, *) ' Printout from radial modules?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) ' Printout from RADGRD?' + YES = GETYN() + IF (YES) LDBPR(1) = .TRUE. + WRITE (6, *) ' Printout from NUCPOT?' + YES = GETYN() + IF (YES) LDBPR(2) = .TRUE. + WRITE (6, *) ' Printout from LODRWF?' + YES = GETYN() + IF (YES) LDBPR(3) = .TRUE. +! + ENDIF ! ! Set options for angular modules ! - WRITE (6, *) ' Printout from angular modules?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) ' Printout from LODCSL?' - YES = GETYN() - IF (YES) LDBPA(1) = .TRUE. - WRITE (6, *) ' Print out T coefficients?' - YES = GETYN() - IF (YES) LDBPA(2) = .TRUE. - ENDIF -! - ENDIF -! - RETURN - END SUBROUTINE SETDBG + WRITE (6, *) ' Printout from angular modules?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) ' Printout from LODCSL?' + YES = GETYN() + IF (YES) LDBPA(1) = .TRUE. + WRITE (6, *) ' Print out T coefficients?' + YES = GETYN() + IF (YES) LDBPA(2) = .TRUE. + ENDIF +! + ENDIF +! + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rhfs90/setdbg_I.f90 b/src/appl/rhfs90/setdbg_I.f90 index 1efb8b7cd..57bb83b4b 100644 --- a/src/appl/rhfs90/setdbg_I.f90 +++ b/src/appl/rhfs90/setdbg_I.f90 @@ -1,9 +1,9 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE setdbg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/setsum.f90 b/src/appl/rhfs90/setsum.f90 index c83ed2c72..78e943b54 100644 --- a/src/appl/rhfs90/setsum.f90 +++ b/src/appl/rhfs90/setsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSUM(NAME, NCI) + SUBROUTINE SETSUM(NAME, NCI) ! * ! Open the .sum files on stream 24 and 29 * ! * @@ -11,50 +11,50 @@ SUBROUTINE SETSUM(NAME, NCI) ! Updated by Per Jonsson 28 Oct 1999 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCI - CHARACTER, INTENT(IN) :: NAME*24 + INTEGER, INTENT(IN) :: NCI + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR + INTEGER :: K, IERR CHARACTER :: FILNAM1*256, FILNAM2*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! File hfs92.sum is FORMATTED ! - K = INDEX(NAME,' ') - IF (NCI == 0) THEN - FILNAM1 = NAME(1:K-1)//'.ch' - FILNAM2 = NAME(1:K-1)//'.choffd' - ELSE - FILNAM1 = NAME(1:K-1)//'.h' - FILNAM2 = NAME(1:K-1)//'.hoffd' - ENDIF - FORM = 'FORMATTED' - STATUS = 'NEW' + K = INDEX(NAME,' ') + IF (NCI == 0) THEN + FILNAM1 = NAME(1:K-1)//'.ch' + FILNAM2 = NAME(1:K-1)//'.choffd' + ELSE + FILNAM1 = NAME(1:K-1)//'.h' + FILNAM2 = NAME(1:K-1)//'.hoffd' + ENDIF + FORM = 'FORMATTED' + STATUS = 'NEW' ! - CALL OPENFL (29, FILNAM1, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (6, *) 'Error when opening', FILNAM1 - STOP - ENDIF + CALL OPENFL (29, FILNAM1, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (6, *) 'Error when opening', FILNAM1 + STOP + ENDIF ! - CALL OPENFL (24, FILNAM2, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (6, *) 'Error when opening', FILNAM2 - STOP - ENDIF + CALL OPENFL (24, FILNAM2, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (6, *) 'Error when opening', FILNAM2 + STOP + ENDIF ! - RETURN - END SUBROUTINE SETSUM + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rhfs90/setsum_I.f90 b/src/appl/rhfs90/setsum_I.f90 index a9ec192c7..cb6b996e0 100644 --- a/src/appl/rhfs90/setsum_I.f90 +++ b/src/appl/rhfs90/setsum_I.f90 @@ -1,11 +1,11 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE setsum (NAME, NCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (NAME, NCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rhfs90/strsum.f90 b/src/appl/rhfs90/strsum.f90 index 51542c638..beeb4d191 100644 --- a/src/appl/rhfs90/strsum.f90 +++ b/src/appl/rhfs90/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * ! Generates the first part of hfs92.sum (on stream 24 and 29). * ! * @@ -9,13 +9,13 @@ SUBROUTINE STRSUM ! Written by P. Jonsson Last revision: 20 Oct 1999 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:03 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE eigv_C USE nsmdat_C, ONLY: SQN, DMOMNM, QMOMB, & HFSI=>SQN, HFSD=>DMOMNM, HFSQ=>QMOMB @@ -24,28 +24,28 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE engouth_I + USE engouth_I IMPLICIT NONE !----------------------------------------------- ! ! Write nuclear data ! - WRITE (24, 302) HFSI - WRITE (24, 303) HFSD - WRITE (24, 304) HFSQ - WRITE (29, 302) HFSI - WRITE (29, 303) HFSD - WRITE (29, 304) HFSQ + WRITE (24, 302) HFSI + WRITE (24, 303) HFSD + WRITE (24, 304) HFSQ + WRITE (29, 302) HFSI + WRITE (29, 303) HFSD + WRITE (29, 304) HFSQ ! ! Write the list of eigenpair indices ! -! CALL ENGOUTH (EAV, EVAL, IATJPO, IASPAR, IVEC, NVEC, 3) +! CALL ENGOUTH (EAV, EVAL, IATJPO, IASPAR, IVEC, NVEC, 3) ! - RETURN + RETURN ! - 302 FORMAT('Nuclear spin ',1P,D22.15,' au') - 303 FORMAT('Nuclear magnetic dipole moment ',1P,D22.15,' n.m.') - 304 FORMAT('Nuclear electric quadrupole moment ',1P,D22.15,' barns') - RETURN + 302 FORMAT('Nuclear spin ',1P,D22.15,' au') + 303 FORMAT('Nuclear magnetic dipole moment ',1P,D22.15,' n.m.') + 304 FORMAT('Nuclear electric quadrupole moment ',1P,D22.15,' barns') + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rhfs90/strsum_I.f90 b/src/appl/rhfs90/strsum_I.f90 index 1bb96ff0f..65daa8973 100644 --- a/src/appl/rhfs90/strsum_I.f90 +++ b/src/appl/rhfs90/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/01/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/Makefile b/src/appl/rmcdhf90/Makefile old mode 100755 new mode 100644 index f0168cba2..294a911d9 --- a/src/appl/rmcdhf90/Makefile +++ b/src/appl/rmcdhf90/Makefile @@ -10,7 +10,7 @@ MODL92 = ${SRCLIBDIR}/lib9290 MODDVD = ${SRCLIBDIR}/libdvd90 GRASPLIBS =-l9290 -lmod -ldvd90 -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} APP_OBJ= mpi_s.o \ @@ -36,7 +36,7 @@ APP_OBJ= mpi_s.o \ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - ${LAPACK_LIBS} + ${LAPACK_LIBS} .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I ${MODDVD} \ @@ -46,5 +46,4 @@ $(EXE): $(APP_OBJ) $(FC) -c $(FC_FLAGS) $< -o $@ clean: - -rm -f *.o *.mod core - + -rm -f *.o *.mod core diff --git a/src/appl/rmcdhf90/cofpot.f90 b/src/appl/rmcdhf90/cofpot.f90 index 2efc168cf..5910437e5 100644 --- a/src/appl/rmcdhf90/cofpot.f90 +++ b/src/appl/rmcdhf90/cofpot.f90 @@ -1,36 +1,36 @@ - SUBROUTINE COFPOT(EOL, J, NPTS) + SUBROUTINE COFPOT(EOL, J, NPTS) !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE pote_C USE mpi_s !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcof_I - USE ypot_I - USE xpot_I - USE lagcon_I - USE dacon_I + USE setcof_I + USE ypot_I + USE xpot_I + USE lagcon_I + USE dacon_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: NPTS - LOGICAL :: EOL + INTEGER :: J + INTEGER :: NPTS + LOGICAL :: EOL !----------------------------------------------------------------------- - CALL SETCOF (EOL, J) - CALL YPOT (J) - CALL XPOT (J) - CALL LAGCON (J, NPROCS) - CALL DACON - - RETURN - END SUBROUTINE COFPOT + CALL SETCOF (EOL, J) + CALL YPOT (J) + CALL XPOT (J) + CALL LAGCON (J, NPROCS) + CALL DACON + + RETURN + END SUBROUTINE COFPOT diff --git a/src/appl/rmcdhf90/cofpot_I.f90 b/src/appl/rmcdhf90/cofpot_I.f90 index b791aa6ce..f507268b3 100644 --- a/src/appl/rmcdhf90/cofpot_I.f90 +++ b/src/appl/rmcdhf90/cofpot_I.f90 @@ -1,12 +1,12 @@ - MODULE cofpot_I + MODULE cofpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cofpot (EOL, J, NPTS) - LOGICAL :: EOL - INTEGER :: J - INTEGER :: NPTS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cofpot (EOL, J, NPTS) + LOGICAL :: EOL + INTEGER :: J + INTEGER :: NPTS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/consis.f90 b/src/appl/rmcdhf90/consis.f90 index e8b26d4df..b5bbe52bc 100644 --- a/src/appl/rmcdhf90/consis.f90 +++ b/src/appl/rmcdhf90/consis.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE CONSIS(J) + SUBROUTINE CONSIS(J) ! * ! This routine computes the weighted self-consistency of orbital J * ! * ! Written by Farid A Parpia, at OXFORD Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE int_C USE scf_C @@ -22,22 +22,22 @@ SUBROUTINE CONSIS(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTP, I - REAL(DOUBLE) :: SCMEA, DELTAO + INTEGER :: MTP, I + REAL(DOUBLE) :: SCMEA, DELTAO !----------------------------------------------- ! ! - SCMEA = 0.0D00 - MTP = MIN(MTP0,MF(J)) - DO I = 1, MTP - DELTAO = ABS(P(I)-PF(I,J)) + ABS(Q(I)-QF(I,J)) - SCMEA = DMAX1(DELTAO,SCMEA) - END DO - SCNSTY(J) = SCMEA*SQRT(UCF(J)) + SCMEA = 0.0D00 + MTP = MIN(MTP0,MF(J)) + DO I = 1, MTP + DELTAO = ABS(P(I)-PF(I,J)) + ABS(Q(I)-QF(I,J)) + SCMEA = DMAX1(DELTAO,SCMEA) + END DO + SCNSTY(J) = SCMEA*SQRT(UCF(J)) ! - RETURN - END SUBROUTINE CONSIS + RETURN + END SUBROUTINE CONSIS diff --git a/src/appl/rmcdhf90/consis_I.f90 b/src/appl/rmcdhf90/consis_I.f90 index a21d55ce0..f25585730 100644 --- a/src/appl/rmcdhf90/consis_I.f90 +++ b/src/appl/rmcdhf90/consis_I.f90 @@ -1,10 +1,10 @@ - MODULE consis_I + MODULE consis_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE consis (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE consis (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/csfwgt.f90 b/src/appl/rmcdhf90/csfwgt.f90 index 9f21fd51c..7c5c18e94 100644 --- a/src/appl/rmcdhf90/csfwgt.f90 +++ b/src/appl/rmcdhf90/csfwgt.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE CSFWGT(LSTDIO) + SUBROUTINE CSFWGT(LSTDIO) ! * ! Print the weights of the largest five CSF contributors to each * ! ASF. * @@ -13,13 +13,13 @@ SUBROUTINE CSFWGT(LSTDIO) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE jlabl_C, LABJ=>JLBR, LABP=>JLBP @@ -32,39 +32,39 @@ SUBROUTINE CSFWGT(LSTDIO) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(IN) :: LSTDIO + LOGICAL, INTENT(IN) :: LSTDIO !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(5) :: ICONF + INTEGER, DIMENSION(5) :: ICONF INTEGER :: IV, JBLOCK, NCF, NCFPAT, NCMINPAT, NEVECPAT, NEVECOFF, NELT, & - ICF, IVTJPO, IVSPAR, I, J, ITEMP, IREM, IP + ICF, IVTJPO, IVSPAR, I, J, ITEMP, IREM, IP REAL(DOUBLE) :: TEMP, W REAL(DOUBLE), DIMENSION(5) :: COEFF - CHARACTER :: RECORD*256, CNUM*8 + CHARACTER :: RECORD*256, CNUM*8 !----------------------------------------------- ! ! ! POINTER (idxblk(:)) ! idx(i= 1,ncmin) is the block where ! - - IF (LSTDIO) THEN - WRITE (ISTDO, 300) - ELSE - WRITE (24, 300) - ENDIF - - DO IV = 1, NCMIN + + IF (LSTDIO) THEN + WRITE (ISTDO, 300) + ELSE + WRITE (24, 300) + ENDIF + + DO IV = 1, NCMIN ! loop over eigenvectors - - JBLOCK = IDXBLK(IV) - NCF = NCFBLK(JBLOCK) - NCFPAT = NCFPAST(JBLOCK) - NCMINPAT = NCMINPAST(JBLOCK) - NEVECPAT = NEVECPAST(JBLOCK) - NEVECOFF = NEVECPAT + (IV - NCMINPAT - 1)*NCF - NELT = MIN(5,NCF) !Find maximum 5 ... within block - ICF = ICCMIN(IV) + + JBLOCK = IDXBLK(IV) + NCF = NCFBLK(JBLOCK) + NCFPAT = NCFPAST(JBLOCK) + NCMINPAT = NCMINPAST(JBLOCK) + NEVECPAT = NEVECPAST(JBLOCK) + NEVECOFF = NEVECPAT + (IV - NCMINPAT - 1)*NCF + NELT = MIN(5,NCF) !Find maximum 5 ... within block + ICF = ICCMIN(IV) !GGGG ivtjpo = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -72,62 +72,62 @@ SUBROUTINE CSFWGT(LSTDIO) ELSE ivspar = 1 END IF -!GG IVTJPO = IATJPO(IV) ! j-value related -!GG IVSPAR = IASPAR(IV) ! parity related - - - DO I = 1, NELT - COEFF(I) = EVEC(NEVECOFF + I) - ICONF(I) = I - END DO - +!GG IVTJPO = IATJPO(IV) ! j-value related +!GG IVSPAR = IASPAR(IV) ! parity related + + + DO I = 1, NELT + COEFF(I) = EVEC(NEVECOFF + I) + ICONF(I) = I + END DO + ! sort the first nelt in decreasing order - DO I = 1, NELT - DO J = I + 1, NELT - IF (ABS(COEFF(J)) <= ABS(COEFF(I))) CYCLE - TEMP = COEFF(I) - COEFF(I) = COEFF(J) - COEFF(J) = TEMP - ITEMP = ICONF(I) - ICONF(I) = ICONF(J) - ICONF(J) = ITEMP - END DO - END DO - - L20: DO I = NELT + 1, NCF - W = EVEC(NEVECOFF + I) - IF (W==0.D0 .OR. ABS(W)<=ABS(COEFF(NELT))) CYCLE L20 + DO I = 1, NELT + DO J = I + 1, NELT + IF (ABS(COEFF(J)) <= ABS(COEFF(I))) CYCLE + TEMP = COEFF(I) + COEFF(I) = COEFF(J) + COEFF(J) = TEMP + ITEMP = ICONF(I) + ICONF(I) = ICONF(J) + ICONF(J) = ITEMP + END DO + END DO + + L20: DO I = NELT + 1, NCF + W = EVEC(NEVECOFF + I) + IF (W==0.D0 .OR. ABS(W)<=ABS(COEFF(NELT))) CYCLE L20 ! we have a non-zero value larger than the largest so far - DO J = 1, NELT - IF (ABS(W) <= ABS(COEFF(J))) CYCLE - COEFF(NELT:1+J:(-1)) = COEFF(NELT-1:J:(-1)) - ICONF(NELT:1+J:(-1)) = ICONF(NELT-1:J:(-1)) - COEFF(J) = W - ICONF(J) = I - CYCLE L20 - END DO - END DO L20 - -!GG IP = (IASPAR(IV) + 3)/2 + DO J = 1, NELT + IF (ABS(W) <= ABS(COEFF(J))) CYCLE + COEFF(NELT:1+J:(-1)) = COEFF(NELT-1:J:(-1)) + ICONF(NELT:1+J:(-1)) = ICONF(NELT-1:J:(-1)) + COEFF(J) = W + ICONF(J) = I + CYCLE L20 + END DO + END DO L20 + +!GG IP = (IASPAR(IV) + 3)/2 ip = ivspar - - IF (LSTDIO) THEN + + IF (LSTDIO) THEN WRITE (ISTDO, 320) JBLOCK, ICF, LABJ(IVTJPO), LABP(IP), (COEFF(I),I& - =1,NELT) - WRITE (ISTDO, 330) (ICONF(I),I=1,NELT) - ELSE - + =1,NELT) + WRITE (ISTDO, 330) (ICONF(I),I=1,NELT) + ELSE + WRITE (24, 320) JBLOCK, ICF, LABJ(IVTJPO), LABP(IP), (COEFF(I),I=1,& - NELT) - WRITE (24, 330) (ICONF(I),I=1,NELT) - ENDIF - END DO - + NELT) + WRITE (24, 330) (ICONF(I),I=1,NELT) + ENDIF + END DO + 300 FORMAT(/,'Weights of major contributors to ASF:'/,/,& - 'Block Level J Parity CSF contributions'/) - 310 FORMAT(1X,A14,80A) - 320 FORMAT(I3,1X,I5,2X,2A4,5(3X,F8.4)) - 330 FORMAT(19X,5(3X,I8)) - - RETURN - END SUBROUTINE CSFWGT + 'Block Level J Parity CSF contributions'/) + 310 FORMAT(1X,A14,80A) + 320 FORMAT(I3,1X,I5,2X,2A4,5(3X,F8.4)) + 330 FORMAT(19X,5(3X,I8)) + + RETURN + END SUBROUTINE CSFWGT diff --git a/src/appl/rmcdhf90/csfwgt_I.f90 b/src/appl/rmcdhf90/csfwgt_I.f90 index 4104ccc06..3058257cf 100644 --- a/src/appl/rmcdhf90/csfwgt_I.f90 +++ b/src/appl/rmcdhf90/csfwgt_I.f90 @@ -1,10 +1,10 @@ - MODULE csfwgt_I + MODULE csfwgt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE csfwgt (LSTDIO) - LOGICAL, INTENT(IN) :: LSTDIO - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE csfwgt (LSTDIO) + LOGICAL, INTENT(IN) :: LSTDIO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/dacon.f90 b/src/appl/rmcdhf90/dacon.f90 index e2594282c..2da3f9e8d 100644 --- a/src/appl/rmcdhf90/dacon.f90 +++ b/src/appl/rmcdhf90/dacon.f90 @@ -1,7 +1,7 @@ - + !*********************************************************************** ! * - SUBROUTINE DACON + SUBROUTINE DACON ! * ! This routine includes the contribution from the off-diagonal * ! I(a,b) integrals in the 'exchange' term. * @@ -11,13 +11,13 @@ SUBROUTINE DACON ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE npot_C @@ -30,31 +30,31 @@ SUBROUTINE DACON !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IORB, MFI, I - REAL(DOUBLE) :: TWOC, COEFF, FK, RPORII, PFI, QFI, ZBCI + INTEGER :: K, IORB, MFI, I + REAL(DOUBLE) :: TWOC, COEFF, FK, RPORII, PFI, QFI, ZBCI !----------------------------------------------- ! ! - TWOC = C + C + TWOC = C + C ! - DO K = 1, NDCOF + DO K = 1, NDCOF ! - IORB = NDA(K) - CALL DPBDT (IORB) - MFI = MF(IORB) - COEFF = DA(K) - FK = DBLE(NAK(IORB)) + IORB = NDA(K) + CALL DPBDT (IORB) + MFI = MF(IORB) + COEFF = DA(K) + FK = DBLE(NAK(IORB)) ! - DO I = 2, MFI - RPORII = 1.0D0/(H*RPOR(I)) - PFI = PF(I,IORB) - QFI = QF(I,IORB) - ZBCI = ZZ(I)/C - XP(I) = XP(I) + COEFF*(TA(I)*RPORII+FK*PFI-(TWOC*R(I)+ZBCI)*QFI) - XQ(I) = XQ(I) + COEFF*(TB(I)*RPORII-FK*QFI+ZBCI*PFI) - END DO + DO I = 2, MFI + RPORII = 1.0D0/(H*RPOR(I)) + PFI = PF(I,IORB) + QFI = QF(I,IORB) + ZBCI = ZZ(I)/C + XP(I) = XP(I) + COEFF*(TA(I)*RPORII+FK*PFI-(TWOC*R(I)+ZBCI)*QFI) + XQ(I) = XQ(I) + COEFF*(TB(I)*RPORII-FK*QFI+ZBCI*PFI) + END DO ! - END DO + END DO ! - RETURN - END SUBROUTINE DACON + RETURN + END SUBROUTINE DACON diff --git a/src/appl/rmcdhf90/dacon_I.f90 b/src/appl/rmcdhf90/dacon_I.f90 index d2374027a..f908ea6eb 100644 --- a/src/appl/rmcdhf90/dacon_I.f90 +++ b/src/appl/rmcdhf90/dacon_I.f90 @@ -1,9 +1,9 @@ - MODULE dacon_I + MODULE dacon_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dacon - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dacon + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/dampck.f90 b/src/appl/rmcdhf90/dampck.f90 index 6fca8e675..08fbca0e1 100644 --- a/src/appl/rmcdhf90/dampck.f90 +++ b/src/appl/rmcdhf90/dampck.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DAMPCK(IPR, J, ED1, ED2) + SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ! * ! This subroutine determines the damping factor appropriate to the * ! present orbital. The algorithm is taken from C Froese Fischer's * @@ -9,33 +9,33 @@ SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE damp_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IPR - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(INOUT) :: ED1 - REAL(DOUBLE), INTENT(INOUT) :: ED2 + INTEGER, INTENT(INOUT) :: IPR + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(INOUT) :: ED1 + REAL(DOUBLE), INTENT(INOUT) :: ED2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: ADAPTV + LOGICAL :: ADAPTV !----------------------------------------------- ! ! The damping is adaptive (i.e., can be modified by this SUBROUTINE) ! if and only if ODAMP(J) .GE. 0.0 ! - ADAPTV = ODAMP(J) >= 0.0D00 + ADAPTV = ODAMP(J) >= 0.0D00 ! ED2 = (ED2-E(J))/ED2 IF (ADAPTV) THEN @@ -51,5 +51,5 @@ SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ! Save the relative difference for the next update of this orbital PED(J) = ED2 ! - RETURN - END SUBROUTINE DAMPCK + RETURN + END SUBROUTINE DAMPCK diff --git a/src/appl/rmcdhf90/dampck_I.f90 b/src/appl/rmcdhf90/dampck_I.f90 index bd0aee119..527ab298a 100644 --- a/src/appl/rmcdhf90/dampck_I.f90 +++ b/src/appl/rmcdhf90/dampck_I.f90 @@ -1,14 +1,14 @@ - MODULE dampck_I + MODULE dampck_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dampck (IPR, J, ED1, ED2) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(INOUT) :: IPR - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(INOUT) :: ED1 - REAL(DOUBLE), INTENT(INOUT) :: ED2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dampck (IPR, J, ED1, ED2) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(INOUT) :: IPR + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(INOUT) :: ED1 + REAL(DOUBLE), INTENT(INOUT) :: ED2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/dampor.f90 b/src/appl/rmcdhf90/dampor.f90 index bbbaef398..c4567e938 100644 --- a/src/appl/rmcdhf90/dampor.f90 +++ b/src/appl/rmcdhf90/dampor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DAMPOR(J, INV, ODAMPJ) + SUBROUTINE DAMPOR(J, INV, ODAMPJ) ! * ! This subroutine damps the orbital wave function with index J. it * ! also stores the previous determination of this orbital. * @@ -10,13 +10,13 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) ! Written by Farid A Parpia, at Oxford Last update: 22 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE damp_C USE def_C @@ -28,29 +28,29 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I -! USE count_I + USE rint_I +! USE count_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J - INTEGER, INTENT(INOUT) :: INV - REAL(DOUBLE), INTENT(IN) :: ODAMPJ + INTEGER, INTENT(INOUT) :: INV + REAL(DOUBLE), INTENT(IN) :: ODAMPJ !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPO, MTPN, MTP, I, NNCFF, MFJ - REAL(DOUBLE) :: EPS, FACTOR, POLDI, QOLDI, DNORM, DNFAC, SGN - LOGICAL :: CHECK + INTEGER :: MTPO, MTPN, MTP, I, NNCFF, MFJ + REAL(DOUBLE) :: EPS, FACTOR, POLDI, QOLDI, DNORM, DNFAC, SGN + LOGICAL :: CHECK !----------------------------------------------- ! ! ! Initialization ! !ww EPS = 0.1D 00*ACCY - EPS = 0.01D00*ACCY - CHECK = .NOT.NOINVT(J) + EPS = 0.01D00*ACCY + CHECK = .NOT.NOINVT(J) ! ! Damp orbital J using the damping factor ABS (ODAMP(J)): ODAMP(J) ! is restricted to the open interval (-1,1) by DATSCF ; the meaning @@ -63,80 +63,80 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) !XHH odampj goes to the argument ! ODAMPJ = ABS (ODAMP(J)) ! - IF (ODAMPJ > EPS) THEN + IF (ODAMPJ > EPS) THEN ! - FACTOR = 1.0D00 - ODAMPJ + FACTOR = 1.0D00 - ODAMPJ ! - PZ(J) = FACTOR*P0 + ODAMPJ*PZ(J) + PZ(J) = FACTOR*P0 + ODAMPJ*PZ(J) ! - MTPO = MF(J) - MTPN = MTP0 - MTP0 = MTPO + MTPO = MF(J) + MTPN = MTP0 + MTP0 = MTPO ! - MTP = MAX(MTPN,MTPO) - DO I = 1, MTP - POLDI = PF(I,J) - PF(I,J) = FACTOR*P(I) + ODAMPJ*PF(I,J) - P(I) = POLDI - QOLDI = QF(I,J) - QF(I,J) = FACTOR*Q(I) + ODAMPJ*QF(I,J) - Q(I) = QOLDI - END DO + MTP = MAX(MTPN,MTPO) + DO I = 1, MTP + POLDI = PF(I,J) + PF(I,J) = FACTOR*P(I) + ODAMPJ*PF(I,J) + P(I) = POLDI + QOLDI = QF(I,J) + QF(I,J) = FACTOR*Q(I) + ODAMPJ*QF(I,J) + Q(I) = QOLDI + END DO ! ! Compute normalization factor ! - MF(J) = MTP - DNORM = RINT(J,J,0) - DNFAC = 1.0D00/SQRT(DNORM) + MF(J) = MTP + DNORM = RINT(J,J,0) + DNFAC = 1.0D00/SQRT(DNORM) ! ! Determine if inversion is necessary ! - IF (CHECK) THEN - CALL COUNT (PF(:NNNP,J), MTP, NNCFF, SGN) - IF (SGN < 0.0D00) THEN - INV = INV + 1 - DNFAC = -DNFAC - ENDIF - ENDIF + IF (CHECK) THEN + CALL COUNT (PF(:NNNP,J), MTP, NNCFF, SGN) + IF (SGN < 0.0D00) THEN + INV = INV + 1 + DNFAC = -DNFAC + ENDIF + ENDIF ! - PZ(J) = PZ(J)*DNFAC - PF(:MTP,J) = DNFAC*PF(:MTP,J) - QF(:MTP,J) = DNFAC*QF(:MTP,J) + PZ(J) = PZ(J)*DNFAC + PF(:MTP,J) = DNFAC*PF(:MTP,J) + QF(:MTP,J) = DNFAC*QF(:MTP,J) ! ! Find new MF(J) ! - MFJ = MTP + 1 - 3 CONTINUE - MFJ = MFJ - 1 - IF (ABS(PF(MFJ,J)) < EPS) THEN - PF(MFJ,J) = 0.0D00 - QF(MFJ,J) = 0.0D00 - GO TO 3 - ELSE - MF(J) = MFJ - ENDIF -! - ELSE -! - PZ(J) = P0 -! - MTPO = MF(J) - MTPN = MTP0 - MTP0 = MTPO -! - MTP = MAX(MTPN,MTPO) - DO I = 1, MTP - POLDI = PF(I,J) - PF(I,J) = P(I) - P(I) = POLDI - QOLDI = QF(I,J) - QF(I,J) = Q(I) - Q(I) = QOLDI - END DO -! - MF(J) = MTP -! - ENDIF -! - RETURN - END SUBROUTINE DAMPOR + MFJ = MTP + 1 + 3 CONTINUE + MFJ = MFJ - 1 + IF (ABS(PF(MFJ,J)) < EPS) THEN + PF(MFJ,J) = 0.0D00 + QF(MFJ,J) = 0.0D00 + GO TO 3 + ELSE + MF(J) = MFJ + ENDIF +! + ELSE +! + PZ(J) = P0 +! + MTPO = MF(J) + MTPN = MTP0 + MTP0 = MTPO +! + MTP = MAX(MTPN,MTPO) + DO I = 1, MTP + POLDI = PF(I,J) + PF(I,J) = P(I) + P(I) = POLDI + QOLDI = QF(I,J) + QF(I,J) = Q(I) + Q(I) = QOLDI + END DO +! + MF(J) = MTP +! + ENDIF +! + RETURN + END SUBROUTINE DAMPOR diff --git a/src/appl/rmcdhf90/dampor_I.f90 b/src/appl/rmcdhf90/dampor_I.f90 index 75258c5c3..47d78b116 100644 --- a/src/appl/rmcdhf90/dampor_I.f90 +++ b/src/appl/rmcdhf90/dampor_I.f90 @@ -1,13 +1,13 @@ - MODULE dampor_I + MODULE dampor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dampor (J, INV, ODAMPJ) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(INOUT) :: INV - REAL(DOUBLE), INTENT(IN) :: ODAMPJ - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dampor (J, INV, ODAMPJ) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(INOUT) :: INV + REAL(DOUBLE), INTENT(IN) :: ODAMPJ + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/defcor.f90 b/src/appl/rmcdhf90/defcor.f90 index 163134c74..0a0a85dca 100644 --- a/src/appl/rmcdhf90/defcor.f90 +++ b/src/appl/rmcdhf90/defcor.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE DEFCOR(J) + SUBROUTINE DEFCOR(J) ! * ! Compute the deferred corrections for orbital J . * ! * ! Last updated: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE wave_C @@ -21,21 +21,21 @@ SUBROUTINE DEFCOR(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: W3 = 1.0D00/120.0D00 - REAL(DOUBLE), PARAMETER :: W2 = -15.0D00*W3 - REAL(DOUBLE), PARAMETER :: W1 = 40.0D00*W3 + REAL(DOUBLE), PARAMETER :: W3 = 1.0D00/120.0D00 + REAL(DOUBLE), PARAMETER :: W2 = -15.0D00*W3 + REAL(DOUBLE), PARAMETER :: W1 = 40.0D00*W3 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, MFJM3, MFJM2 - LOGICAL :: FIRST + INTEGER :: I, MFJM3, MFJM2 + LOGICAL :: FIRST !----------------------------------------------- ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! The deferred corrections for the first two points are ! unnecessary, because the integration always commences @@ -43,33 +43,33 @@ SUBROUTINE DEFCOR(J) ! deferred correction at the third and subsequent points ! only ! - IF (FIRST) THEN - DP(:2) = 0.0D00 - DQ(:2) = 0.0D00 - FIRST = .FALSE. - ENDIF + IF (FIRST) THEN + DP(:2) = 0.0D00 + DQ(:2) = 0.0D00 + FIRST = .FALSE. + ENDIF ! ! Intermediate points ! - MFJM3 = MF(J) - 3 - DO I = 3, MFJM3 + MFJM3 = MF(J) - 3 + DO I = 3, MFJM3 ! DP(I) = W3*(PF(I + 3,J) - PF(I - 2,J)) + & W2*(PF(I + 2,J) - PF(I - 1,J)) + & - W1*(PF(I + 1,J) - PF(I,J)) + W1*(PF(I + 1,J) - PF(I,J)) ! DQ(I) = W3*(QF(I + 3,J) - QF(I - 2,J)) + & W2*(QF(I + 2,J) - QF(I - 1,J)) + & - W1*(QF(I + 1,J) - QF(I,J)) + W1*(QF(I + 1,J) - QF(I,J)) ! - END DO + END DO ! ! Set remaining deferred corrections to zero: slopes are ! small in this region ! - MFJM2 = MF(J) - 2 - DP(MFJM2:N) = 0.0D00 - DQ(MFJM2:N) = 0.0D00 + MFJM2 = MF(J) - 2 + DP(MFJM2:N) = 0.0D00 + DQ(MFJM2:N) = 0.0D00 ! - RETURN - END SUBROUTINE DEFCOR + RETURN + END SUBROUTINE DEFCOR diff --git a/src/appl/rmcdhf90/defcor_I.f90 b/src/appl/rmcdhf90/defcor_I.f90 index eb9bee78b..3a454b279 100644 --- a/src/appl/rmcdhf90/defcor_I.f90 +++ b/src/appl/rmcdhf90/defcor_I.f90 @@ -1,10 +1,10 @@ - MODULE defcor_I + MODULE defcor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE defcor (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE defcor (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/dsubrs.f90 b/src/appl/rmcdhf90/dsubrs.f90 index 75a991bee..826896a3f 100644 --- a/src/appl/rmcdhf90/dsubrs.f90 +++ b/src/appl/rmcdhf90/dsubrs.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) + REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) ! * ! The coefficients d for I = r, J = s are calculated here. * ! rs * @@ -29,13 +29,13 @@ REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) ! by parameter jblock ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE hblock_C @@ -44,29 +44,29 @@ REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER , INTENT(IN) :: J - INTEGER :: JBLOCK - LOGICAL , INTENT(IN) :: EOL + INTEGER :: I + INTEGER , INTENT(IN) :: J + INTEGER :: JBLOCK + LOGICAL , INTENT(IN) :: EOL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, KCMIN, IK, JK + INTEGER :: K, KCMIN, IK, JK !----------------------------------------------- - - IF (EOL) THEN - DSUBRS = 0.D0 - DO K = 1, NEVBLK(JBLOCK) - KCMIN = K + NCMINPAST(JBLOCK) - IK = I + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) - JK = J + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) - DSUBRS = DSUBRS + EVEC(IK)*EVEC(JK)*WT(KCMIN) - END DO - ELSE IF (I == J) THEN - DSUBRS = WT(I) - ELSE - DSUBRS = 0.D0 - ENDIF - - RETURN - END FUNCTION DSUBRS + + IF (EOL) THEN + DSUBRS = 0.D0 + DO K = 1, NEVBLK(JBLOCK) + KCMIN = K + NCMINPAST(JBLOCK) + IK = I + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) + JK = J + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) + DSUBRS = DSUBRS + EVEC(IK)*EVEC(JK)*WT(KCMIN) + END DO + ELSE IF (I == J) THEN + DSUBRS = WT(I) + ELSE + DSUBRS = 0.D0 + ENDIF + + RETURN + END FUNCTION DSUBRS diff --git a/src/appl/rmcdhf90/dsubrs_I.f90 b/src/appl/rmcdhf90/dsubrs_I.f90 index e5b89dcbb..bbf2031b5 100644 --- a/src/appl/rmcdhf90/dsubrs_I.f90 +++ b/src/appl/rmcdhf90/dsubrs_I.f90 @@ -1,13 +1,13 @@ - MODULE dsubrs_I + MODULE dsubrs_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION dsubrs (EOL, I, J, JBLOCK) - LOGICAL, INTENT(IN) :: EOL - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER :: JBLOCK - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION dsubrs (EOL, I, J, JBLOCK) + LOGICAL, INTENT(IN) :: EOL + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER :: JBLOCK + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/eigen.f90 b/src/appl/rmcdhf90/eigen.f90 index 5fbd8224a..29b068d21 100644 --- a/src/appl/rmcdhf90/eigen.f90 +++ b/src/appl/rmcdhf90/eigen.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION EIGEN (J) + REAL(KIND(0.0D0)) FUNCTION EIGEN (J) ! * ! This function computes an estimate of the energy of orbital J . * ! * @@ -9,13 +9,13 @@ REAL(KIND(0.0D0)) FUNCTION EIGEN (J) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE orb_C @@ -25,70 +25,70 @@ REAL(KIND(0.0D0)) FUNCTION EIGEN (J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I - USE dpbdt_I + USE quad_I + USE dpbdt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4, PIECE5 + INTEGER :: I + REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4, PIECE5 !----------------------------------------------- ! ! ! Initialization ! - MTP = MF(J) + MTP = MF(J) ! ! Exchange term ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)*XQ(I)-QF(I,J)*XP(I))*RPOR(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = C*PIECE1 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)*XQ(I)-QF(I,J)*XP(I))*RPOR(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = C*PIECE1 ! ! Direct term ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)**2 + QF(I,J)**2)*YP(I)*RPOR(I) - END DO - CALL QUAD (PIECE2) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)**2 + QF(I,J)**2)*YP(I)*RPOR(I) + END DO + CALL QUAD (PIECE2) ! ! Kinetic energy terms ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = QF(I,J)**2*RP(I) - END DO - CALL QUAD (PIECE3) - PIECE3 = 2.0D00*C*C*PIECE3 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = QF(I,J)**2*RP(I) + END DO + CALL QUAD (PIECE3) + PIECE3 = 2.0D00*C*C*PIECE3 ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)*QF(I,J))*RPOR(I) - END DO - CALL QUAD (PIECE4) - PIECE4 = -2.0D00*DBLE(NAK(J))*C*PIECE4 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)*QF(I,J))*RPOR(I) + END DO + CALL QUAD (PIECE4) + PIECE4 = -2.0D00*DBLE(NAK(J))*C*PIECE4 ! - CALL DPBDT (J) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = PF(I,J)*TB(I) - QF(I,J)*TA(I) - END DO - CALL QUAD (PIECE5) - PIECE5 = C*PIECE5/H + CALL DPBDT (J) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = PF(I,J)*TB(I) - QF(I,J)*TA(I) + END DO + CALL QUAD (PIECE5) + PIECE5 = C*PIECE5/H ! ! Assembly ! - EIGEN = PIECE1 + PIECE2 + PIECE3 + PIECE4 + PIECE5 + EIGEN = PIECE1 + PIECE2 + PIECE3 + PIECE4 + PIECE5 ! - RETURN + RETURN ! - END FUNCTION EIGEN + END FUNCTION EIGEN diff --git a/src/appl/rmcdhf90/eigen_I.f90 b/src/appl/rmcdhf90/eigen_I.f90 index 0cebba276..9e1b4dad4 100644 --- a/src/appl/rmcdhf90/eigen_I.f90 +++ b/src/appl/rmcdhf90/eigen_I.f90 @@ -1,10 +1,10 @@ - MODULE eigen_I + MODULE eigen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION eigen (J) - INTEGER, INTENT(IN) :: J - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION eigen (J) + INTEGER, INTENT(IN) :: J + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/endsum.f90 b/src/appl/rmcdhf90/endsum.f90 index cb51dffef..8be7e2c71 100644 --- a/src/appl/rmcdhf90/endsum.f90 +++ b/src/appl/rmcdhf90/endsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENDSUM + SUBROUTINE ENDSUM ! * ! Generates the last part of rscf92.sum (on stream 24). * ! * @@ -12,13 +12,13 @@ SUBROUTINE ENDSUM ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE orb_C @@ -28,9 +28,9 @@ SUBROUTINE ENDSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I - USE engoutgg_I - USE csfwgt_I + USE rint_I + USE engoutgg_I + USE csfwgt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -41,43 +41,43 @@ SUBROUTINE ENDSUM ! ! Write out the orbital properties ! - WRITE (24, 301) - DO I = 1, NW + WRITE (24, 301) + DO I = 1, NW WRITE (24, 302) NP(I),NH(I),E(I),PZ(I),GAMA(I),PF(2,I),QF(2,I), & - SCNSTY(I), MF(I) - END DO + SCNSTY(I), MF(I) + END DO ! - WRITE (24, 303) - DO I = 1, NW - WA = RINT(I,I,-1) - WB = RINT(I,I,1) - WC = RINT(I,I,2) + WRITE (24, 303) + DO I = 1, NW + WA = RINT(I,I,-1) + WB = RINT(I,I,1) + WC = RINT(I,I,2) WD = RINT (I,I, 4) WE = 0.d0 IF (NH(I) /= 's ' .AND. NH(i) /= 'p-') then WE = RINT(I,I,-3) END IF WRITE (24,304) NP(I),NH(I),WE,WA,WB,WC,WD, UCF(I) - END DO + END DO ! - IF (NCMIN /= 0) THEN - MODE = 0 + IF (NCMIN /= 0) THEN + MODE = 0 CALL ENGOUTGG (EVAL,ICCMIN,NCMIN,MODE) -!GG CALL ENGOUT (EVAL, IATJPO, IASPAR, ICCMIN, NCMIN, MODE) - CALL CSFWGT (.FALSE.) - ENDIF +!GG CALL ENGOUT (EVAL, IATJPO, IASPAR, ICCMIN, NCMIN, MODE) + CALL CSFWGT (.FALSE.) + ENDIF ! - CLOSE(24) + CLOSE(24) ! - RETURN + RETURN ! 301 FORMAT(/,'Radial wavefunction summary:'/,/,67X,'Self'/,'Subshell',6X,'e',& - 13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',3X,'Consistency',' MTP'/) - 302 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,3(D11.3),I5) + 13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',3X,'Consistency',' MTP'/) + 302 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,3(D11.3),I5) 303 FORMAT (/18X,'-3',14X,'-1',29X,'2',14x,'4',5X,'Generalised' & /'Subshell',4X,'< r >',8X,'< r >',8X,'< r >',8X, & '< r >',8X,'< r >',6X,'occupation'/) 304 FORMAT (1X,1I2,1A2,1X,1P,6D15.5) - RETURN + RETURN ! - END SUBROUTINE ENDSUM + END SUBROUTINE ENDSUM diff --git a/src/appl/rmcdhf90/endsum_I.f90 b/src/appl/rmcdhf90/endsum_I.f90 index e5a24ce22..991069be6 100644 --- a/src/appl/rmcdhf90/endsum_I.f90 +++ b/src/appl/rmcdhf90/endsum_I.f90 @@ -1,10 +1,10 @@ - MODULE endsum_I + MODULE endsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE endsum + SUBROUTINE endsum !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/engoutgg.f90 b/src/appl/rmcdhf90/engoutgg.f90 index 5ee154e07..2397eb978 100644 --- a/src/appl/rmcdhf90/engoutgg.f90 +++ b/src/appl/rmcdhf90/engoutgg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) + SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -16,13 +16,13 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE jlabl_C, LABJ=>JLBR, LABP=>JLBP USE blkidx_C @@ -35,30 +35,30 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - INTEGER, INTENT(IN) :: ILEV(NN) - REAL(DOUBLE), INTENT(IN) :: E(NN) + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: ILEV(NN) + REAL(DOUBLE), INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, JBLOCK, I, IP, JTOT - REAL(DOUBLE) :: EAV, EAU, ECM, EEV + REAL(DOUBLE) :: EAV, EAU, ECM, EEV !----------------------------------------------- ! ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - JBLOCK = IDXBLK(J) - EAV = EAVBLK(JBLOCK) - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + JBLOCK = IDXBLK(J) + EAV = EAVBLK(JBLOCK) + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN ip = 2 @@ -66,22 +66,22 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 jblock = idxblk(j) JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -90,21 +90,21 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 jblock = idxblk(j) JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -113,19 +113,19 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,4X,2A4,1P,3D21.12) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,4X,2A4,1P,3D21.12) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! END SUBROUTINE ENGOUTGG diff --git a/src/appl/rmcdhf90/engoutgg_I.f90 b/src/appl/rmcdhf90/engoutgg_I.f90 index dd05d1705..70db01503 100644 --- a/src/appl/rmcdhf90/engoutgg_I.f90 +++ b/src/appl/rmcdhf90/engoutgg_I.f90 @@ -1,14 +1,14 @@ - MODULE engoutgg_I + MODULE engoutgg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/estim.f90 b/src/appl/rmcdhf90/estim.f90 index 1a98cc7c9..e4a665fd1 100644 --- a/src/appl/rmcdhf90/estim.f90 +++ b/src/appl/rmcdhf90/estim.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ESTIM(J) + SUBROUTINE ESTIM(J) ! * ! This subprogram implements Part 1 of Algorithm 7.1 of C Froese * ! Fischer, Comput Phys Rep, 3 (1986) 320-321. * @@ -9,10 +9,10 @@ SUBROUTINE ESTIM(J) ! * !*********************************************************************** !...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE def_C USE grid_C @@ -22,23 +22,23 @@ SUBROUTINE ESTIM(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NPJ, NAKABS - REAL(DOUBLE) :: ALPHA, CSQ, FNREL, FKABS, FKAP2, ZALPHA, GAMMA, EBYM + INTEGER :: NPJ, NAKABS + REAL(DOUBLE) :: ALPHA, CSQ, FNREL, FKABS, FKAP2, ZALPHA, GAMMA, EBYM !----------------------------------------------- ! ! Initializations ! - ALPHA = 1.0D00/C - CSQ = C*C - NPJ = NP(J) - NAKABS = ABS(NAK(J)) - FNREL = DBLE(NPJ - NAKABS) - FKABS = DBLE(NAKABS) - FKAP2 = FKABS*FKABS + ALPHA = 1.0D00/C + CSQ = C*C + NPJ = NP(J) + NAKABS = ABS(NAK(J)) + FNREL = DBLE(NPJ - NAKABS) + FKABS = DBLE(NAKABS) + FKAP2 = FKABS*FKABS ! ! Set ZINF, the asymptotic charge seen by the electron ! @@ -46,31 +46,31 @@ SUBROUTINE ESTIM(J) ! ! Changed on 07/06/93 by WPW ! - ZINF = Z + DBLE((-NELEC) + 1) + ZINF = Z + DBLE((-NELEC) + 1) ! ! Set the lower bound ! - ZALPHA = ZINF*ALPHA - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL + 0.5D00))**2) - EPSMIN = (1.0D00 - EBYM)*CSQ - ELSE - EPSMIN = 0.25D00*CSQ/DBLE(NPJ*NPJ) - ENDIF - EMIN = EPSMIN + ZALPHA = ZINF*ALPHA + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL + 0.5D00))**2) + EPSMIN = (1.0D00 - EBYM)*CSQ + ELSE + EPSMIN = 0.25D00*CSQ/DBLE(NPJ*NPJ) + ENDIF + EMIN = EPSMIN ! ! Set the upper bound ! - ZALPHA = Z*ALPHA - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL - 0.5D00))**2) - EPSMAX = (1.0D00 - EBYM)*CSQ - ELSE - EPSMAX = CSQ + CSQ - ENDIF - EMAX = EPSMAX + ZALPHA = Z*ALPHA + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL - 0.5D00))**2) + EPSMAX = (1.0D00 - EBYM)*CSQ + ELSE + EPSMAX = CSQ + CSQ + ENDIF + EMAX = EPSMAX ! - RETURN - END SUBROUTINE ESTIM + RETURN + END SUBROUTINE ESTIM diff --git a/src/appl/rmcdhf90/estim_I.f90 b/src/appl/rmcdhf90/estim_I.f90 index 65fa1e39f..d20f4a03c 100644 --- a/src/appl/rmcdhf90/estim_I.f90 +++ b/src/appl/rmcdhf90/estim_I.f90 @@ -1,10 +1,10 @@ - MODULE estim_I + MODULE estim_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE estim (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE estim (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/fco.f90 b/src/appl/rmcdhf90/fco.f90 index ba94ca89f..98694fdf5 100644 --- a/src/appl/rmcdhf90/fco.f90 +++ b/src/appl/rmcdhf90/fco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) + REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) ! * ! This routine evaluates a coefficient * ! * @@ -26,68 +26,68 @@ REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) !XHH 1997.03.05 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, IIQA=>IQA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I USE IQ_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: K - INTEGER :: IR - INTEGER , INTENT(IN) :: IA - INTEGER , INTENT(IN) :: IB + INTEGER :: K + INTEGER :: IR + INTEGER , INTENT(IN) :: IA + INTEGER , INTENT(IN) :: IB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQA, IQF, KAPPA - REAL(DOUBLE) :: FAC + INTEGER :: IQA, IQF, KAPPA + REAL(DOUBLE) :: FAC !----------------------------------------------- ! - IF (IA == IB) THEN + IF (IA == IB) THEN ! IQA = IQ (IA,IR) -! IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) +! IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) ! - IF (K == 0) THEN - FCO = DBLE((IQA*(IQA - 1))/2) - ELSE - IQF = NKJ(IA) + 1 - IF (IQA == IQF) THEN - KAPPA = NAK(IA) - FAC = CLRX(KAPPA,K,KAPPA)*DBLE(IQA) - FCO = -0.5D0*FAC*FAC - ELSE - FCO = 0.D0 - ENDIF - ENDIF + IF (K == 0) THEN + FCO = DBLE((IQA*(IQA - 1))/2) + ELSE + IQF = NKJ(IA) + 1 + IF (IQA == IQF) THEN + KAPPA = NAK(IA) + FAC = CLRX(KAPPA,K,KAPPA)*DBLE(IQA) + FCO = -0.5D0*FAC*FAC + ELSE + FCO = 0.D0 + ENDIF + ENDIF ! - ELSE + ELSE ! - IF (K == 0) THEN + IF (K == 0) THEN FCO = DBLE (IQ (IA,IR)*IQ (IB,IR)) ! FCO = DBLE(IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8)*IBITS(& -! IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8)) - ELSE - FCO = 0.D0 - ENDIF +! IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8)) + ELSE + FCO = 0.D0 + ENDIF ! - ENDIF - RETURN + ENDIF + RETURN !* ! 300 FORMAT (/' ',1I2 ! : /' f (',1I2,1A2,',',1I2,1A2,') = ',1PD21.14, ! : /' ',1I3/) !* - END FUNCTION FCO + END FUNCTION FCO diff --git a/src/appl/rmcdhf90/fco_I.f90 b/src/appl/rmcdhf90/fco_I.f90 index 2e8e2377b..2bba93a8e 100644 --- a/src/appl/rmcdhf90/fco_I.f90 +++ b/src/appl/rmcdhf90/fco_I.f90 @@ -1,13 +1,13 @@ - MODULE fco_I + MODULE fco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION fco (K, IR, IA, IB) - INTEGER, INTENT(IN) :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION fco (K, IR, IA, IB) + INTEGER, INTENT(IN) :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/gco.f90 b/src/appl/rmcdhf90/gco.f90 index 084679281..d82fd2f8b 100644 --- a/src/appl/rmcdhf90/gco.f90 +++ b/src/appl/rmcdhf90/gco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) + REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! * ! This routine evaluates a coefficient * ! * @@ -19,46 +19,46 @@ REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! Written by Farid A Parpia, at Oxford Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, IIQA=>IQA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I USE IQ_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: K - INTEGER :: IR - INTEGER , INTENT(IN) :: IA - INTEGER , INTENT(IN) :: IB + INTEGER :: K + INTEGER :: IR + INTEGER , INTENT(IN) :: IA + INTEGER , INTENT(IN) :: IB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQA, IQB - REAL(DOUBLE) :: FAC -! LOGICAL :: FULLA, FULLB + INTEGER :: IQA, IQB + REAL(DOUBLE) :: FAC +! LOGICAL :: FULLA, FULLB !----------------------------------------------- ! IQA = IQ (IA,IR) IQB = IQ (IB,IR) -!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) -!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) - IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN - FAC = CLRX(NAK(IA),K,NAK(IB)) - GCO = -DBLE(IQA*IQB)*FAC*FAC - ELSE - GCO = 0.0D00 - ENDIF - - RETURN - END FUNCTION GCO +!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) +!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) + IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN + FAC = CLRX(NAK(IA),K,NAK(IB)) + GCO = -DBLE(IQA*IQB)*FAC*FAC + ELSE + GCO = 0.0D00 + ENDIF + + RETURN + END FUNCTION GCO diff --git a/src/appl/rmcdhf90/gco_I.f90 b/src/appl/rmcdhf90/gco_I.f90 index 5a759536a..f5a176568 100644 --- a/src/appl/rmcdhf90/gco_I.f90 +++ b/src/appl/rmcdhf90/gco_I.f90 @@ -1,13 +1,13 @@ - MODULE gco_I + MODULE gco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) - INTEGER :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) + INTEGER :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/getald.f90 b/src/appl/rmcdhf90/getald.f90 index 5dafec703..51d9ae00c 100644 --- a/src/appl/rmcdhf90/getald.f90 +++ b/src/appl/rmcdhf90/getald.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETALD + SUBROUTINE GETALD ! ! Interactively determines the data governing AL problem. ! @@ -13,11 +13,11 @@ SUBROUTINE GETALD ! Block version by Xinghong He Last revision: 13 Jul 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man USE def_C @@ -27,44 +27,44 @@ SUBROUTINE GETALD USE scf_C USE iounit_C !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getaldwt_I + USE getaldwt_I USE iq_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM, J, I - REAL(DOUBLE) :: SUM - LOGICAL :: GETYN, YES + INTEGER :: IQADUM, J, I + REAL(DOUBLE) :: SUM + LOGICAL :: GETYN, YES !----------------------------------------------- ! WRITE (ISTDE, *) '(E)AL type calculation; H(DC) will not be ', & - 'diagonalised;' - WRITE (ISTDE, *) 'getald ...' - WRITE (ISTDE, *) 'ncf=', NCF - - CALL ALLOC (WT, NCF, 'WT', 'GETALD') - - CALL GETALDWT (NCF, WT) - - DO J = 1, NW - SUM = 0.D0 - DO I = 1, NCF - SUM = SUM + WT(I)*DBLE(IQ(J,I)) - END DO - UCF(J) = SUM - END DO - - NCMIN = 0 - NSCF = 12 - NSIC = 2 + (NW - NFIX)/4 - ORTHST = .FALSE. - - RETURN - END SUBROUTINE GETALD + 'diagonalised;' + WRITE (ISTDE, *) 'getald ...' + WRITE (ISTDE, *) 'ncf=', NCF + + CALL ALLOC (WT, NCF, 'WT', 'GETALD') + + CALL GETALDWT (NCF, WT) + + DO J = 1, NW + SUM = 0.D0 + DO I = 1, NCF + SUM = SUM + WT(I)*DBLE(IQ(J,I)) + END DO + UCF(J) = SUM + END DO + + NCMIN = 0 + NSCF = 12 + NSIC = 2 + (NW - NFIX)/4 + ORTHST = .FALSE. + + RETURN + END SUBROUTINE GETALD diff --git a/src/appl/rmcdhf90/getald_I.f90 b/src/appl/rmcdhf90/getald_I.f90 index e5c0ff84e..8005052b2 100644 --- a/src/appl/rmcdhf90/getald_I.f90 +++ b/src/appl/rmcdhf90/getald_I.f90 @@ -1,9 +1,9 @@ - MODULE getald_I + MODULE getald_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getald - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getald + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/getaldwt.f90 b/src/appl/rmcdhf90/getaldwt.f90 index b24908f7e..4caaab5b9 100644 --- a/src/appl/rmcdhf90/getaldwt.f90 +++ b/src/appl/rmcdhf90/getaldwt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETALDWT(NCF, WT) + SUBROUTINE GETALDWT(NCF, WT) ! ! Interactively determines the weights. ! @@ -9,13 +9,13 @@ SUBROUTINE GETALDWT(NCF, WT) ! Written by Xinghong He Last revision: 19 Mar 1999 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -25,68 +25,68 @@ SUBROUTINE GETALDWT(NCF, WT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NCF - REAL(DOUBLE) :: WT(NCF) + INTEGER , INTENT(IN) :: NCF + REAL(DOUBLE) :: WT(NCF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, N159, NCMIN - REAL(DOUBLE) :: SUMWGT, FTJPOI + INTEGER :: I, N159, NCMIN + REAL(DOUBLE) :: SUMWGT, FTJPOI !----------------------------------------------- - + ! Select a method to assign level weights for ncmin > 1 case - - WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' - + + WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' + ! Let user try 10 times to get the correct input. 10 is BIG ! enough since the idea here is to allow user mistakes and ! at the same time to avoid an infinity loop. - - DO I = 1, 10 - READ (ISTDI, *) N159 - IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT - WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I - END DO - - IF (I > 10) STOP 'Must be running un-attended' - + + DO I = 1, 10 + READ (ISTDI, *) N159 + IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT + WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I + END DO + + IF (I > 10) STOP 'Must be running un-attended' + !------------------------------------------------------------------ - - SELECT CASE (N159) ! Equal weight - CASE (1) - WT = 1.D0 - SUMWGT = DBLE(NCF) - CASE (5) ! Standard weight - SUMWGT = 0.D0 - DO I = 1, NCF - FTJPOI = DBLE(ITJPO(I)) - WT(I) = FTJPOI - SUMWGT = SUMWGT + FTJPOI - END DO - CASE (9) ! User-input weight - - 123 CONTINUE + + SELECT CASE (N159) ! Equal weight + CASE (1) + WT = 1.D0 + SUMWGT = DBLE(NCF) + CASE (5) ! Standard weight + SUMWGT = 0.D0 + DO I = 1, NCF + FTJPOI = DBLE(ITJPO(I)) + WT(I) = FTJPOI + SUMWGT = SUMWGT + FTJPOI + END DO + CASE (9) ! User-input weight + + 123 CONTINUE WRITE (ISTDE, *) 'Enter the (relative) weights of the', NCF, & - ' levels :' - READ (ISTDI, *) (WT(I),I=1,NCMIN) - - SUMWGT = 0.D0 - DO I = 1, NCF - IF (WT(I) <= 0.D0) THEN - WRITE (ISTDE, *) 'Weights must exceed 0;' - GO TO 123 - ELSE - SUMWGT = SUMWGT + WT(I) - ENDIF - END DO - - CASE DEFAULT - WRITE (ISTDE, *) 'Impossible ! Because it was guarded' - STOP - END SELECT - - SUMWGT = 1.D0/SUMWGT - WT = SUMWGT*WT - - RETURN - END SUBROUTINE GETALDWT + ' levels :' + READ (ISTDI, *) (WT(I),I=1,NCMIN) + + SUMWGT = 0.D0 + DO I = 1, NCF + IF (WT(I) <= 0.D0) THEN + WRITE (ISTDE, *) 'Weights must exceed 0;' + GO TO 123 + ELSE + SUMWGT = SUMWGT + WT(I) + ENDIF + END DO + + CASE DEFAULT + WRITE (ISTDE, *) 'Impossible ! Because it was guarded' + STOP + END SELECT + + SUMWGT = 1.D0/SUMWGT + WT = SUMWGT*WT + + RETURN + END SUBROUTINE GETALDWT diff --git a/src/appl/rmcdhf90/getaldwt_I.f90 b/src/appl/rmcdhf90/getaldwt_I.f90 index be2f2b096..7c4949467 100644 --- a/src/appl/rmcdhf90/getaldwt_I.f90 +++ b/src/appl/rmcdhf90/getaldwt_I.f90 @@ -1,12 +1,12 @@ - MODULE getaldwt_I + MODULE getaldwt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getaldwt (NCF, WT) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: NCF - REAL(DOUBLE), DIMENSION(NCF), INTENT(INOUT) :: WT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getaldwt (NCF, WT) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: NCF + REAL(DOUBLE), DIMENSION(NCF), INTENT(INOUT) :: WT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/getold.f90 b/src/appl/rmcdhf90/getold.f90 index 68f91e157..81ebb75ad 100644 --- a/src/appl/rmcdhf90/getold.f90 +++ b/src/appl/rmcdhf90/getold.f90 @@ -1,11 +1,11 @@ !*********************************************************************** ! * - SUBROUTINE GETOLD(IDBLK) -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 + SUBROUTINE GETOLD(IDBLK) +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE blkidx_C @@ -18,66 +18,66 @@ SUBROUTINE GETOLD(IDBLK) USE invt_C, ONLY: noinvt USE orthct_C USE ORB_C - USE ORBA_C, ONLY: IORDER - USE CORRE_C, ONLY: LCORRE + USE ORBA_C, ONLY: IORDER + USE CORRE_C, ONLY: LCORRE USE scf_C, ONLY: SCNSTY,METHOD !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lodstate_I - USE getoldwt_I - USE prtrsl_I - USE getrsl_I + USE lodstate_I + USE getoldwt_I + USE prtrsl_I + USE getrsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: IDBLK(*)*8 + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM - INTEGER , DIMENSION(NNNW) :: INDX - INTEGER :: I, NSUBS, NORDER, LOC, NOFFSET, JBLOCK, J - LOGICAL :: GETYN, YES - CHARACTER :: RECORD*256 + INTEGER :: IQADUM + INTEGER , DIMENSION(NNNW) :: INDX + INTEGER :: I, NSUBS, NORDER, LOC, NOFFSET, JBLOCK, J + LOGICAL :: GETYN, YES + CHARACTER :: RECORD*256 !----------------------------------------------- - + !WRITE (istde,*) 'EOL type calculation;' - + ! lodstate fills ! nevblk(), ncmaxblk() ! ncmin, iccmin(1:ncmin) -- via items (memories allocated there) - - CALL ALLOC (NCMAXBLK, NBLOCK, 'NCMAXBLK', 'GETOLD') - CALL ALLOC (NEVBLK, NBLOCK, 'NEVBLK', 'GETOLD' ) + + CALL ALLOC (NCMAXBLK, NBLOCK, 'NCMAXBLK', 'GETOLD') + CALL ALLOC (NEVBLK, NBLOCK, 'NEVBLK', 'GETOLD' ) !cjb ncmaxblk & nevblk initialised in lodstate ! NEVBLK = 0 ! NCMAXBLK = 0 !cjb - + !cjb LODSTATE(NBLOCK, NCFBLK, IDBLK, NEVBLK, NCMAXBLK) -> (IDBLK) -! CALL LODSTATE (NBLOCK, NCFBLK(1), IDBLK, NEVBLK, NCMAXBLK) - CALL LODSTATE (IDBLK) +! CALL LODSTATE (NBLOCK, NCFBLK(1), IDBLK, NEVBLK, NCMAXBLK) + CALL LODSTATE (IDBLK) !cjb ! ! Allocate the storage for and set the weights ! - CALL ALLOC (WEIGHT, NCMIN, 'WEIGHT', 'GETOLD') - - CALL GETOLDWT (NDEF, NCMIN, WEIGHT) + CALL ALLOC (WEIGHT, NCMIN, 'WEIGHT', 'GETOLD') + + CALL GETOLDWT (NDEF, NCMIN, WEIGHT) ! ! Eigenvector damping ! - CALL ALLOC (CDAMP, NCMIN, 'CDAMP', 'GETOLD') + CALL ALLOC (CDAMP, NCMIN, 'CDAMP', 'GETOLD') ! - CDAMP(:NCMIN) = 0.D0 + CDAMP(:NCMIN) = 0.D0 ! ! Print the list of all subshells ! - WRITE (ISTDE, *) 'Radial functions' - CALL PRTRSL + WRITE (ISTDE, *) 'Radial functions' + CALL PRTRSL ! ! Determine which orbitals are to be varied, which are fixed. ! Quantities determined here: @@ -85,77 +85,77 @@ SUBROUTINE GETOLD(IDBLK) ! Instead of broadcasting these quantities, we broadcast ! the intermediate result from GETRSL (see below) ! - LFIX(:NW) = .TRUE. - - WRITE (ISTDE, *) 'Enter orbitals to be varied (Updating order)' - CALL GETRSL (INDX, NSUBS) - - LFIX(INDX(:NSUBS)) = .FALSE. + LFIX(:NW) = .TRUE. + + WRITE (ISTDE, *) 'Enter orbitals to be varied (Updating order)' + CALL GETRSL (INDX, NSUBS) + + LFIX(INDX(:NSUBS)) = .FALSE. !XHH give a big value, rather than zero to scnsty() - SCNSTY(INDX(:NSUBS)) = 1.D20 - NFIX = NW - NSUBS + SCNSTY(INDX(:NSUBS)) = 1.D20 + NFIX = NW - NSUBS IF (NFIX == NW) WRITE (ISTDE, *) & 'All subshell radial wavefunctions are fixed;', & - ' performing CI calculation.' - + ' performing CI calculation.' + ! Determine orbital updating order - - NORDER = 0 - DO I = 1, NW - IORDER(I) = I - IF (LFIX(I)) CYCLE - NORDER = NORDER + 1 - IORDER(I) = INDX(NORDER) - END DO + + NORDER = 0 + DO I = 1, NW + IORDER(I) = I + IF (LFIX(I)) CYCLE + NORDER = NORDER + 1 + IORDER(I) = INDX(NORDER) + END DO ! !XHH added a array to store the index of the correlation functions ! - LCORRE(:NW) = .TRUE. - - WRITE (ISTDE, *) 'Which of these are spectroscopic orbitals?' - CALL GETRSL (INDX, NSUBS) - IF (NSUBS > 0) THEN - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - METHOD(LOC) = 1 - NOINVT(LOC) = .FALSE. - ODAMP(LOC) = 0.D0 - LCORRE(LOC) = .FALSE. - END DO - ENDIF - + LCORRE(:NW) = .TRUE. + + WRITE (ISTDE, *) 'Which of these are spectroscopic orbitals?' + CALL GETRSL (INDX, NSUBS) + IF (NSUBS > 0) THEN + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + METHOD(LOC) = 1 + NOINVT(LOC) = .FALSE. + ODAMP(LOC) = 0.D0 + LCORRE(LOC) = .FALSE. + END DO + ENDIF + ! Set NSIC. It will be non-zero if all orbitals to be varied are ! spectroscopic orbitals - - NSIC = (NW - NFIX)/4 - DO I = 1, NW - IF (.NOT.(.NOT.LFIX(I) .AND. LCORRE(I))) CYCLE - NSIC = 0 - EXIT - END DO -! - NSCF = 24 - NSOLV = 3 - ORTHST = .TRUE. + + NSIC = (NW - NFIX)/4 + DO I = 1, NW + IF (.NOT.(.NOT.LFIX(I) .AND. LCORRE(I))) CYCLE + NSIC = 0 + EXIT + END DO +! + NSCF = 24 + NSOLV = 3 + ORTHST = .TRUE. ! ! Make the allocation for the auxiliary vector required ! by SUBROUTINE NEWCO ! - CALL ALLOC (RWTDUM, NCMIN, 'RWTDUM', 'GETOLD') + CALL ALLOC (RWTDUM, NCMIN, 'RWTDUM', 'GETOLD') ! ! Place the block numbers of the all ncmin eigenstate(wanted) ! in array idxblk ! - CALL ALLOC (IDXBLK, NCMIN, 'IDXBLK', 'GETOLD') - NOFFSET = 0 - DO JBLOCK = 1, NBLOCK - DO J = 1, NEVBLK(JBLOCK) - IDXBLK(J+NOFFSET) = JBLOCK - END DO - NOFFSET = NOFFSET + NEVBLK(JBLOCK) - END DO - IF (NOFFSET /= NCMIN) STOP 'getold: ncmin trouble' - - RETURN + CALL ALLOC (IDXBLK, NCMIN, 'IDXBLK', 'GETOLD') + NOFFSET = 0 + DO JBLOCK = 1, NBLOCK + DO J = 1, NEVBLK(JBLOCK) + IDXBLK(J+NOFFSET) = JBLOCK + END DO + NOFFSET = NOFFSET + NEVBLK(JBLOCK) + END DO + IF (NOFFSET /= NCMIN) STOP 'getold: ncmin trouble' + + RETURN END SUBROUTINE GETOLD diff --git a/src/appl/rmcdhf90/getold_I.f90 b/src/appl/rmcdhf90/getold_I.f90 index 0c5f44f23..c93b99f4f 100644 --- a/src/appl/rmcdhf90/getold_I.f90 +++ b/src/appl/rmcdhf90/getold_I.f90 @@ -1,8 +1,8 @@ - MODULE getold_I + MODULE getold_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 - SUBROUTINE getold (IDBLK) - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 + SUBROUTINE getold (IDBLK) + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/getoldwt.f90 b/src/appl/rmcdhf90/getoldwt.f90 index fbe721f9f..3305ff2ef 100644 --- a/src/appl/rmcdhf90/getoldwt.f90 +++ b/src/appl/rmcdhf90/getoldwt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) + SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) ! ! Interactively determines the weights for EOL calculation. ! It's modified to always ask the question for the weight @@ -11,86 +11,86 @@ SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) ! !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE iounit_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDEF - INTEGER , INTENT(IN) :: NCMIN - REAL(DOUBLE) :: WT(NCMIN) + INTEGER :: NDEF + INTEGER , INTENT(IN) :: NCMIN + REAL(DOUBLE) :: WT(NCMIN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, N159 - REAL(DOUBLE) :: SUMWGT + INTEGER :: I, N159 + REAL(DOUBLE) :: SUMWGT !----------------------------------------------- - + ! Standard weights: ncmin=1, OL calculation - - IF (NCMIN == 1) THEN - WT(1) = -1.D0 - RETURN - ENDIF - + + IF (NCMIN == 1) THEN + WT(1) = -1.D0 + RETURN + ENDIF + ! Select a method to assign level weights for ncmin > 1 case - - WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' - + + WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' + ! Let user try 10 times to get the correct input. 10 is BIG ! enough since the idea here is to allow user mistakes and ! at the same time to avoid an infinity loop. - - DO I = 1, 10 - READ (ISTDI, *) N159 - IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT - WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I - END DO + + DO I = 1, 10 + READ (ISTDI, *) N159 + IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT + WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I + END DO IF (NDEF.EQ.0) THEN WRITE(734,*) n159,'! level weights' END IF - - IF (I > 10) STOP - + + IF (I > 10) STOP + !------------------------------------------------------------------ - - SELECT CASE (N159) ! Equal weight - CASE (1) - WT = -2.D0 - CASE (5) ! Standard weight - WT = -1.D0 - CASE (9) ! User-input weight - - 123 CONTINUE + + SELECT CASE (N159) ! Equal weight + CASE (1) + WT = -2.D0 + CASE (5) ! Standard weight + WT = -1.D0 + CASE (9) ! User-input weight + + 123 CONTINUE WRITE (ISTDE, *) 'Enter the (relative) weights of the', NCMIN, & - ' levels :' - READ (ISTDI, *) (WT(I),I=1,NCMIN) - - SUMWGT = 0.D0 - DO I = 1, NCMIN - IF (WT(I) <= 0.D0) THEN - WRITE (ISTDE, *) 'Weights must exceed 0;' - GO TO 123 - ELSE - SUMWGT = SUMWGT + WT(I) - ENDIF - END DO + ' levels :' + READ (ISTDI, *) (WT(I),I=1,NCMIN) + + SUMWGT = 0.D0 + DO I = 1, NCMIN + IF (WT(I) <= 0.D0) THEN + WRITE (ISTDE, *) 'Weights must exceed 0;' + GO TO 123 + ELSE + SUMWGT = SUMWGT + WT(I) + ENDIF + END DO IF (NDEF == 0) THEN WRITE(734,*) (wt(i), i = 1, ncmin) END IF - SUMWGT = 1.D0/SUMWGT - WT = SUMWGT*WT - - CASE DEFAULT - WRITE (ISTDE, *) 'Impossible ! Because it was guarded' - STOP - END SELECT - - RETURN - END SUBROUTINE GETOLDWT + SUMWGT = 1.D0/SUMWGT + WT = SUMWGT*WT + + CASE DEFAULT + WRITE (ISTDE, *) 'Impossible ! Because it was guarded' + STOP + END SELECT + + RETURN + END SUBROUTINE GETOLDWT diff --git a/src/appl/rmcdhf90/getoldwt_I.f90 b/src/appl/rmcdhf90/getoldwt_I.f90 index 55fb8321d..035e67c51 100644 --- a/src/appl/rmcdhf90/getoldwt_I.f90 +++ b/src/appl/rmcdhf90/getoldwt_I.f90 @@ -1,12 +1,12 @@ - MODULE getoldwt_I + MODULE getoldwt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 - SUBROUTINE getoldwt (NDEF, NCMIN, WT) - USE vast_kind_param,ONLY: DOUBLE - INTEGER :: NDEF +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 + SUBROUTINE getoldwt (NDEF, NCMIN, WT) + USE vast_kind_param,ONLY: DOUBLE + INTEGER :: NDEF !VAST...Dummy argument NDEF is not referenced in this routine. - INTEGER, INTENT(IN) :: NCMIN - REAL(DOUBLE), DIMENSION(NCMIN), INTENT(INOUT) :: WT - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: NCMIN + REAL(DOUBLE), DIMENSION(NCMIN), INTENT(INOUT) :: WT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/getscd.f90 b/src/appl/rmcdhf90/getscd.f90 index 1e6f44962..a5ef5c0b6 100644 --- a/src/appl/rmcdhf90/getscd.f90 +++ b/src/appl/rmcdhf90/getscd.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) + SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) ! * ! Interactively determines the data governing the SCF problem. * ! * @@ -13,17 +13,17 @@ SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) ! Xinghong He 98-08-06 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE COUN_C + USE COUN_C USE damp_C, ONLY: odamp, cdamp - USE DEF_C + USE DEF_C USE default_C USE fixd_C, ONLY: lfix USE iounit_C @@ -41,37 +41,37 @@ SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE setqic_I - USE radgrd_I - USE nucpot_I - USE setrwfa_I - USE getald_I - USE getold_I - USE convrt_I - USE getrsl_I + USE getyn_I + USE setiso_I + USE setqic_I + USE radgrd_I + USE nucpot_I + USE setrwfa_I + USE getald_I + USE getold_I + USE convrt_I + USE getrsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(OUT) :: EOL - CHARACTER :: ISOFILE*(*) - CHARACTER :: RWFFILE*(*) - CHARACTER :: IDBLK(*)*8 + LOGICAL, INTENT(OUT) :: EOL + CHARACTER :: ISOFILE*(*) + CHARACTER :: RWFFILE*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*6, PARAMETER :: MYNAME = 'GETSCD' + CHARACTER*6, PARAMETER :: MYNAME = 'GETSCD' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM - INTEGER , DIMENSION(NNNW) :: INDX - INTEGER :: I, J, IEND, IBEG, LENTH, NSUBS, LOC - REAL(DOUBLE) :: ODAMPU, CDAMPU - LOGICAL :: YES - CHARACTER :: RECORD*80, CNUM*20 + INTEGER :: IQADUM + INTEGER , DIMENSION(NNNW) :: INDX + INTEGER :: I, J, IEND, IBEG, LENTH, NSUBS, LOC + REAL(DOUBLE) :: ODAMPU, CDAMPU + LOGICAL :: YES + CHARACTER :: RECORD*80, CNUM*20 !----------------------------------------------- ! ! Open, check, load data from, and close the .iso file @@ -80,62 +80,62 @@ SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Set default speed of light and grid parameters ! - C = CVAC - IF (NPARM == 0) THEN - RNT = EXP((-65.D0/16.D0))/Z - H = 0.5D0**4 - N = MIN(220,NNNP) - ELSE + C = CVAC + IF (NPARM == 0) THEN + RNT = EXP((-65.D0/16.D0))/Z + H = 0.5D0**4 + N = MIN(220,NNNP) + ELSE ! default comes here !CFF .. should be Z-dependent - RNT = 2.0D-06/Z - H = 5.D-2 - N = NNNP - ENDIF - HP = 0.D0 + RNT = 2.0D-06/Z + H = 5.D-2 + N = NNNP + ENDIF + HP = 0.D0 ! ! ACCY is an estimate of the accuracy of the numerical procedures ! ACCY = H**6 - IF (NDEF /= 0) THEN - + IF (NDEF /= 0) THEN + WRITE (ISTDE,'(A)',ADVANCE='NO')'Change the default speed of',& - ' light or radial grid parameters? (y/n) ' - YES = GETYN() - IF (YES) THEN + ' light or radial grid parameters? (y/n) ' + YES = GETYN() + IF (YES) THEN WRITE (istde,*) 'Speed of light = ',CVAC,';', ' revise ?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter the revised value:' - READ (5, *) C - ENDIF + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter the revised value:' + READ (5, *) C + ENDIF ! ! Determine the parameters controlling the radial grid ! WRITE (ISTDE, *) 'The default radial grid parameters for ',& - 'this case are:' - WRITE (ISTDE, *) ' RNT = ', RNT - WRITE (ISTDE, *) ' H = ', H - WRITE (ISTDE, *) ' HP = ', HP - WRITE (ISTDE, *) ' N = ', N - WRITE (ISTDE, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (ISTDE, *) 'Enter H:' - READ (5, *) H - WRITE (ISTDE, *) 'Enter HP:' - READ (5, *) HP - WRITE (ISTDE, *) 'Enter N:' - READ (5, *) N + 'this case are:' + WRITE (ISTDE, *) ' RNT = ', RNT + WRITE (ISTDE, *) ' H = ', H + WRITE (ISTDE, *) ' HP = ', HP + WRITE (ISTDE, *) ' N = ', N + WRITE (ISTDE, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (ISTDE, *) 'Enter H:' + READ (5, *) H + WRITE (ISTDE, *) 'Enter HP:' + READ (5, *) HP + WRITE (ISTDE, *) 'Enter N:' + READ (5, *) N !b Revised grid WRITE (istde,*) 'Revised RNT = ', RNT WRITE (istde,*) 'Revised H = ', H WRITE (istde,*) 'Revised HP = ', HP WRITE (istde,*) 'Revised N = ', N - ENDIF - ENDIF + ENDIF + ENDIF ! !b !b read ACCY on input @@ -152,59 +152,59 @@ SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Generate $- r \times V_ (r)$ ! - CALL NUCPOT + CALL NUCPOT ! ! Load the subshell radial wavefunction estimates ! - CALL SETRWFA (RWFFILE) + CALL SETRWFA (RWFFILE) ! ! Set some defaults ! - THRESH = 0.05D0 - + THRESH = 0.05D0 + ! IORDER(I) = I ! Completely determined in GETOLD - METHOD(:NW) = 3 - NOINVT(:NW) = .TRUE. -!CFF ODAMP(:NW) = 1.D0 - ODAMP(:NW) = 0.0D0 + METHOD(:NW) = 3 + NOINVT(:NW) = .TRUE. +!CFF ODAMP(:NW) = 1.D0 + ODAMP(:NW) = 0.0D0 PED(:NW) = 0.0D0 - SCNSTY(:NW) = 0.0D0 - - WHERE (NAK(:NW) < 0) - NNODEP(:NW) = NP(:NW) + NAK(:NW) - ELSEWHERE - NNODEP(:NW) = NP(:NW) - NAK(:NW) - 1 - END WHERE - - IF (DIAG) THEN - EOL = .FALSE. - CALL GETALD ! (E)AL type calculation, + SCNSTY(:NW) = 0.0D0 + + WHERE (NAK(:NW) < 0) + NNODEP(:NW) = NP(:NW) + NAK(:NW) + ELSEWHERE + NNODEP(:NW) = NP(:NW) - NAK(:NW) - 1 + END WHERE + + IF (DIAG) THEN + EOL = .FALSE. + CALL GETALD ! (E)AL type calculation, ! H(DC) will not be diagonalised - ELSE IF (LFORDR) THEN - EOL = .TRUE. - CALL GETOLD (IDBLK) ! EOL type calculation - ELSE -!GG WRITE (ISTDE, '(A)', ADVANCE='NO') '(E)OL type calculation? (y/n) ' + ELSE IF (LFORDR) THEN + EOL = .TRUE. + CALL GETOLD (IDBLK) ! EOL type calculation + ELSE +!GG WRITE (ISTDE, '(A)', ADVANCE='NO') '(E)OL type calculation? (y/n) ' EOL = .true. -!GG EOL = GETYN() - IF (EOL) THEN - CALL GETOLD (IDBLK) - ELSE - CALL GETALD ! (E)AL type calculation, +!GG EOL = GETYN() + IF (EOL) THEN + CALL GETOLD (IDBLK) + ELSE + CALL GETALD ! (E)AL type calculation, ! H(DC) will not be diagonalised - ENDIF - ENDIF - - WRITE (ISTDE, *) 'Enter the maximum number of SCF cycles:' - READ (*, *) NSCF + ENDIF + ENDIF + + WRITE (ISTDE, *) 'Enter the maximum number of SCF cycles:' + READ (*, *) NSCF IF (NDEF.EQ.0) THEN WRITE(734,*) NSCF,'! Number of SCF cycles' @@ -212,284 +212,284 @@ SUBROUTINE GETSCD(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Allow the user to modify other defaults ! - IF (NDEF /= 0) THEN - WRITE (ISTDE, '(A)', ADVANCE='NO') 'Modify other defaults? (y/n) ' - YES = GETYN() - ELSE - YES = .FALSE. - ENDIF - - IF (.NOT.YES) RETURN + IF (NDEF /= 0) THEN + WRITE (ISTDE, '(A)', ADVANCE='NO') 'Modify other defaults? (y/n) ' + YES = GETYN() + ELSE + YES = .FALSE. + ENDIF + + IF (.NOT.YES) RETURN !======================================================================= ! From here to end, "other defaults" are handled. For simplicity ! We'll let node-0 do the job and then broadcast results to all ! nodes. !======================================================================= !------------------------------------------- - IF (MYID == 0) THEN ! This is a _big_ IF + IF (MYID == 0) THEN ! This is a _big_ IF !------------------------------------------- ! ! THRESH ! WRITE (ISTDE,*)'An oscillation in the large-component of the ',& - 'radial wavefunction is diregarded' + 'radial wavefunction is diregarded' WRITE (ISTDE, *) 'for the purposes of node counting if its ', & - 'amplitude is less than 1/20 the' - WRITE (ISTDE, *) 'maximum amplitude. Revise this?' - YES = GETYN() - IF (YES) THEN - 3 CONTINUE - WRITE (ISTDE, *) 'Enter the new threshold value:' - READ (*, *) THRESH - IF (THRESH <= 0.D0) THEN - WRITE (ISTDE, *) MYNAME, ': This must exceed 0;' - GO TO 3 - ENDIF - ENDIF + 'amplitude is less than 1/20 the' + WRITE (ISTDE, *) 'maximum amplitude. Revise this?' + YES = GETYN() + IF (YES) THEN + 3 CONTINUE + WRITE (ISTDE, *) 'Enter the new threshold value:' + READ (*, *) THRESH + IF (THRESH <= 0.D0) THEN + WRITE (ISTDE, *) MYNAME, ': This must exceed 0;' + GO TO 3 + ENDIF + ENDIF YES = .FALSE. ! ! METHOD ! - + ! Piece only for printing... - - DO I = 1, 4 - - DO J = 1, NW - IF (.NOT.(METHOD(J)==I .AND. .NOT.LFIX(J))) CYCLE + + DO I = 1, 4 + + DO J = 1, NW + IF (.NOT.(METHOD(J)==I .AND. .NOT.LFIX(J))) CYCLE WRITE (ISTDE, *) 'Method ', I, ' is used for ', & 'integrating the radial differential ', & - 'equation for subshells' - GO TO 9 - END DO - - CYCLE - - 9 CONTINUE - IEND = 0 - DO J = 1, NW - IF (METHOD(J)==I .AND. .NOT.LFIX(J)) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - CALL CONVRT (NP(J), CNUM, LENTH) - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IBEG = IEND + 1 - IF (NAK(J) < 0) THEN - IEND = IBEG - RECORD(IBEG:IEND) = NH(J)(1:1) - ELSE - IEND = IBEG + 1 - RECORD(IBEG:IEND) = NH(J)(1:2) - ENDIF - ENDIF - IF (IEND <= 76) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - END DO - IF (IEND<=0 .OR. MYID/=0) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - END DO - + 'equation for subshells' + GO TO 9 + END DO + + CYCLE + + 9 CONTINUE + IEND = 0 + DO J = 1, NW + IF (METHOD(J)==I .AND. .NOT.LFIX(J)) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + CALL CONVRT (NP(J), CNUM, LENTH) + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IBEG = IEND + 1 + IF (NAK(J) < 0) THEN + IEND = IBEG + RECORD(IBEG:IEND) = NH(J)(1:1) + ELSE + IEND = IBEG + 1 + RECORD(IBEG:IEND) = NH(J)(1:2) + ENDIF + ENDIF + IF (IEND <= 76) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + END DO + IF (IEND<=0 .OR. MYID/=0) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + END DO + ! Reads user inputs and fills array indx(1:nsubs) where nsubs itself ! is an output from getrsl. ! METHOD(1:4) is the only output. indx() and nsubs are discarded - + WRITE (ISTDE, *) 'Select a different integration method for ', & - 'any subshell radial wavefunction?' - YES = GETYN() - IF (YES) THEN - DO I = 1, 4 - WRITE (ISTDE, *) 'Method ', I, ':' - CALL GETRSL (INDX, NSUBS) - DO J = 1, NSUBS - LOC = INDX(J) - IF (LFIX(LOC)) CYCLE - METHOD(LOC) = I - END DO - END DO - ENDIF + 'any subshell radial wavefunction?' + YES = GETYN() + IF (YES) THEN + DO I = 1, 4 + WRITE (ISTDE, *) 'Method ', I, ':' + CALL GETRSL (INDX, NSUBS) + DO J = 1, NSUBS + LOC = INDX(J) + IF (LFIX(LOC)) CYCLE + METHOD(LOC) = I + END DO + END DO + ENDIF ! ! NOINVT ! - WRITE (ISTDE, *) 'The first oscillation of the large component' - - DO I = 1, NW - IF (.NOT.(NOINVT(I) .AND. .NOT.LFIX(I))) CYCLE + WRITE (ISTDE, *) 'The first oscillation of the large component' + + DO I = 1, NW + IF (.NOT.(NOINVT(I) .AND. .NOT.LFIX(I))) CYCLE WRITE (ISTDE, *) 'of the following radial wavefunctions ', & - 'will be required to be positive' - GO TO 15 - END DO - + 'will be required to be positive' + GO TO 15 + END DO + WRITE (ISTDE, *) 'of all radial wavefunctions will be required ', & - 'to be positive. Revise this?' - YES = GETYN() - GO TO 17 - 15 CONTINUE - IEND = 0 - DO I = 1, NW - IF (NOINVT(I) .AND. .NOT.LFIX(I)) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - CALL CONVRT (NP(I), CNUM, LENTH) - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IBEG = IEND + 1 - IF (NAK(I) < 0) THEN - IEND = IBEG - RECORD(IBEG:IEND) = NH(I)(1:1) - ELSE - IEND = IBEG + 1 - RECORD(IBEG:IEND) = NH(I)(1:2) - ENDIF - ENDIF - IF (IEND <= 76) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - END DO - IF (IEND > 0) WRITE (ISTDE, *) RECORD(1:IEND) - WRITE (ISTDE, *) 'Revise this?' - YES = GETYN() - 17 CONTINUE - IF (YES) THEN + 'to be positive. Revise this?' + YES = GETYN() + GO TO 17 + 15 CONTINUE + IEND = 0 + DO I = 1, NW + IF (NOINVT(I) .AND. .NOT.LFIX(I)) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + CALL CONVRT (NP(I), CNUM, LENTH) + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IBEG = IEND + 1 + IF (NAK(I) < 0) THEN + IEND = IBEG + RECORD(IBEG:IEND) = NH(I)(1:1) + ELSE + IEND = IBEG + 1 + RECORD(IBEG:IEND) = NH(I)(1:2) + ENDIF + ENDIF + IF (IEND <= 76) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + END DO + IF (IEND > 0) WRITE (ISTDE, *) RECORD(1:IEND) + WRITE (ISTDE, *) 'Revise this?' + YES = GETYN() + 17 CONTINUE + IF (YES) THEN WRITE (ISTDE, *) 'Suppressing enforcement of positive first ', & - 'oscillation:' - CALL GETRSL (INDX, NSUBS) - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - NOINVT(LOC) = .TRUE. - END DO - ENDIF + 'oscillation:' + CALL GETRSL (INDX, NSUBS) + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + NOINVT(LOC) = .TRUE. + END DO + ENDIF ! ! ODAMP ! - DO I = 1, NW - IF (.NOT.(ODAMP(I)/=0.D0 .AND. .NOT.LFIX(I))) CYCLE + DO I = 1, NW + IF (.NOT.(ODAMP(I)/=0.D0 .AND. .NOT.LFIX(I))) CYCLE WRITE (ISTDE, *) 'Subshell accelerating parameters have ', & - 'been set. Revise these?' - YES = GETYN() - GO TO 20 - END DO + 'been set. Revise these?' + YES = GETYN() + GO TO 20 + END DO WRITE (ISTDE, *) 'Set accelerating parameters for subshell ', & - 'radial wavefunctions?' - YES = GETYN() - 20 CONTINUE - IF (YES) THEN + 'radial wavefunctions?' + YES = GETYN() + 20 CONTINUE + IF (YES) THEN WRITE (ISTDE, *) 'Different accelerating parameters for ', & - 'different subshell radial wavefunction?' - YES = GETYN() - IF (YES) THEN - 21 CONTINUE - WRITE (ISTDE, *) 'Enter an accelerating parameter' + 'different subshell radial wavefunction?' + YES = GETYN() + IF (YES) THEN + 21 CONTINUE + WRITE (ISTDE, *) 'Enter an accelerating parameter' WRITE (ISTDE, *) ' (0< ODAMP < 1 allows ODAMP to be ', & - 'reduced as convergence is approached;' + 'reduced as convergence is approached;' WRITE (ISTDE, *) ' -1 < ODAMP < 0 implies |ODAMP| is ', & - 'held constant):' - READ (*, *) ODAMPU - IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN - WRITE (ISTDE, *) MYNAME, ': Value out of range ...' - GO TO 21 - ELSE - CALL GETRSL (INDX, NSUBS) - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - ODAMP(LOC) = ODAMPU - END DO - ENDIF - ELSE - 23 CONTINUE - WRITE (ISTDE, *) 'Enter the accelerating parameter' + 'held constant):' + READ (*, *) ODAMPU + IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN + WRITE (ISTDE, *) MYNAME, ': Value out of range ...' + GO TO 21 + ELSE + CALL GETRSL (INDX, NSUBS) + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + ODAMP(LOC) = ODAMPU + END DO + ENDIF + ELSE + 23 CONTINUE + WRITE (ISTDE, *) 'Enter the accelerating parameter' WRITE (ISTDE, *) ' (0< ODAMP < 1 allows ODAMP to be ', & - 'reduced as convergence is approached;' + 'reduced as convergence is approached;' WRITE (ISTDE, *) ' -1 < ODAMP < 0 implies |ODAMP| is ', & - 'held constant):' - READ (*, *) ODAMPU - IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN - WRITE (ISTDE, *) MYNAME, ': Value out of range ...' - GO TO 23 - ELSE - WHERE (.NOT.LFIX(:NW)) - ODAMP(:NW) = ODAMPU - END WHERE - ENDIF - ENDIF - ENDIF + 'held constant):' + READ (*, *) ODAMPU + IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN + WRITE (ISTDE, *) MYNAME, ': Value out of range ...' + GO TO 23 + ELSE + WHERE (.NOT.LFIX(:NW)) + ODAMP(:NW) = ODAMPU + END WHERE + ENDIF + ENDIF + ENDIF ! ! CDAMP ! WRITE (ISTDE, *) 'Set accelerating parameters for the ', & - 'eigenvectors?' - YES = GETYN() - IF (YES) THEN + 'eigenvectors?' + YES = GETYN() + IF (YES) THEN WRITE (ISTDE, *) 'Different accelerating parameters ', & - 'for each eigenvector?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter an accelerating parameter for' - CALL CONVRT (NCMIN, RECORD, LENTH) - WRITE (ISTDE, *) ' each of the '//RECORD(1:LENTH)//' levels :' - READ (*, *) (CDAMP(I),I=1,NCMIN) - ELSE - WRITE (ISTDE, *) 'Enter the accelerating parameter:' - READ (*, *) CDAMPU - CDAMP(:NCMIN) = CDAMPU - ENDIF - ENDIF + 'for each eigenvector?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter an accelerating parameter for' + CALL CONVRT (NCMIN, RECORD, LENTH) + WRITE (ISTDE, *) ' each of the '//RECORD(1:LENTH)//' levels :' + READ (*, *) (CDAMP(I),I=1,NCMIN) + ELSE + WRITE (ISTDE, *) 'Enter the accelerating parameter:' + READ (*, *) CDAMPU + CDAMP(:NCMIN) = CDAMPU + ENDIF + ENDIF ! ! NSIC ! WRITE (ISTDE, *) 'Following the improvement of each of the ', & - 'subshell radial wavefunctions in turn, ' + 'subshell radial wavefunctions in turn, ' WRITE (ISTDE, *) 'the ', NSIC, ' least self-consistent', & - ' functions will be improved at the' + ' functions will be improved at the' WRITE (ISTDE, *) 'end of the first SCF cycle. Revise this ', & - 'setting?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter the number of additional ', 'improvements:' - READ (*, *) NSIC - ENDIF + 'setting?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter the number of additional ', 'improvements:' + READ (*, *) NSIC + ENDIF ! ! NSOLV ! WRITE (ISTDE, *) 'The maximum number of cycles in attempting ', & - 'to solve each radial equation is ' + 'to solve each radial equation is ' WRITE (ISTDE, *) NSOLV, ' times the principal quantum', & - ' number of the radial' + ' number of the radial' WRITE (ISTDE, *) 'wave-function to be estimated. ', & - 'Revise this setting?' - YES = GETYN() - IF (YES) THEN + 'Revise this setting?' + YES = GETYN() + IF (YES) THEN WRITE (ISTDE, *) 'Enter the factor that multiplies the ', & - 'principal quantum number:' - READ (*, *) NSOLV - ENDIF + 'principal quantum number:' + READ (*, *) NSOLV + ENDIF ! ! Orthogonalisation ! - IF (ORTHST) THEN + IF (ORTHST) THEN WRITE (ISTDE, *) 'Subshell radial wavefunctions will be ', & - 'Schmidt orthogonalised immediately' + 'Schmidt orthogonalised immediately' WRITE (ISTDE, *) 'following their estimation to all ', & - 'functions with poorer self-consistency.' - WRITE (ISTDE, *) ' Revise this?' - YES = GETYN() - IF (YES) ORTHST = .FALSE. - ELSE + 'functions with poorer self-consistency.' + WRITE (ISTDE, *) ' Revise this?' + YES = GETYN() + IF (YES) ORTHST = .FALSE. + ELSE WRITE (ISTDE, *) 'Subshell radial wavefunctions will be ', & - 'Schmidt orthogonalised at the end of' - WRITE (ISTDE, *) 'each SCF cycle. Revise this?' - YES = GETYN() - IF (YES) ORTHST = .TRUE. - ENDIF + 'Schmidt orthogonalised at the end of' + WRITE (ISTDE, *) 'each SCF cycle. Revise this?' + YES = GETYN() + IF (YES) ORTHST = .TRUE. + ENDIF !------------------------------------------- - ENDIF ! end of the _big_ IF + ENDIF ! end of the _big_ IF !------------------------------------------- - RETURN - END SUBROUTINE GETSCD + RETURN + END SUBROUTINE GETSCD diff --git a/src/appl/rmcdhf90/getscd_I.f90 b/src/appl/rmcdhf90/getscd_I.f90 index 9e48a2e01..68db68b9c 100644 --- a/src/appl/rmcdhf90/getscd_I.f90 +++ b/src/appl/rmcdhf90/getscd_I.f90 @@ -1,13 +1,13 @@ - MODULE getscd_I + MODULE getscd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:26:24 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:26:24 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getscd (EOL, IDBLK, ISOFILE, RWFFILE) - LOGICAL, INTENT(OUT) :: EOL - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - CHARACTER (LEN = *) :: ISOFILE - CHARACTER (LEN = *) :: RWFFILE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getscd (EOL, IDBLK, ISOFILE, RWFFILE) + LOGICAL, INTENT(OUT) :: EOL + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + CHARACTER (LEN = *) :: ISOFILE + CHARACTER (LEN = *) :: RWFFILE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/hmout.f90 b/src/appl/rmcdhf90/hmout.f90 index f6dfa2cad..27e679829 100644 --- a/src/appl/rmcdhf90/hmout.f90 +++ b/src/appl/rmcdhf90/hmout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - subroutine hmout(myid, nprocs, ncf) + subroutine hmout(myid, nprocs, ncf) ! * ! Routine for printing the Hamiltonian matrix. * ! * @@ -8,25 +8,25 @@ subroutine hmout(myid, nprocs, ncf) ! Block Version by Xinghong He Last revision: 30 Jan 1999 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: double + USE vast_kind_param, ONLY: double USE hmat_C implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: myid - integer :: nprocs - integer, intent(in) :: ncf + integer :: myid + integer :: nprocs + integer, intent(in) :: ncf !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: ibeg, ico, idiag, list, iro + integer :: ibeg, ico, idiag, list, iro !----------------------------------------------- ! ! @@ -41,49 +41,49 @@ subroutine hmout(myid, nprocs, ncf) ! ibeg = idiag + 1 ! enddo ! - ibeg = 1 - do ico = 1, ncf, 4 - ibeg = iendc(ico - 1) + 1 - idiag = iendc(ico) - do list = ibeg, idiag - iro = irow(list) - write (96, *) 'H(', iro, ico, ')= ', emt(list) - end do + ibeg = 1 + do ico = 1, ncf, 4 + ibeg = iendc(ico - 1) + 1 + idiag = iendc(ico) + do list = ibeg, idiag + iro = irow(list) + write (96, *) 'H(', iro, ico, ')= ', emt(list) + end do !ibeg = idiag + 1 - end do - - ibeg = iendc(1) + 1 - do ico = 2, ncf, 4 - ibeg = iendc(ico - 1) + 1 - idiag = iendc(ico) - do list = ibeg, idiag - iro = irow(list) - write (97, *) 'H(', iro, ico, ')= ', emt(list) - end do + end do + + ibeg = iendc(1) + 1 + do ico = 2, ncf, 4 + ibeg = iendc(ico - 1) + 1 + idiag = iendc(ico) + do list = ibeg, idiag + iro = irow(list) + write (97, *) 'H(', iro, ico, ')= ', emt(list) + end do !ibeg = idiag + 1 - end do - - ibeg = iendc(2) + 1 - do ico = 3, ncf, 4 - ibeg = iendc(ico - 1) + 1 - idiag = iendc(ico) - do list = ibeg, idiag - iro = irow(list) - write (98, *) 'H(', iro, ico, ')= ', emt(list) - end do + end do + + ibeg = iendc(2) + 1 + do ico = 3, ncf, 4 + ibeg = iendc(ico - 1) + 1 + idiag = iendc(ico) + do list = ibeg, idiag + iro = irow(list) + write (98, *) 'H(', iro, ico, ')= ', emt(list) + end do !ibeg = idiag + 1 - end do - - ibeg = iendc(3) + 1 - do ico = 4, ncf, 4 - ibeg = iendc(ico - 1) + 1 - idiag = iendc(ico) - do list = ibeg, idiag - iro = irow(list) - write (99, *) 'H(', iro, ico, ')= ', emt(list) - end do + end do + + ibeg = iendc(3) + 1 + do ico = 4, ncf, 4 + ibeg = iendc(ico - 1) + 1 + idiag = iendc(ico) + do list = ibeg, idiag + iro = irow(list) + write (99, *) 'H(', iro, ico, ')= ', emt(list) + end do !ibeg = idiag + 1 - end do - return - - end subroutine hmout + end do + return + + end subroutine hmout diff --git a/src/appl/rmcdhf90/hmout_I.f90 b/src/appl/rmcdhf90/hmout_I.f90 index 5a9188b41..5eee5be59 100644 --- a/src/appl/rmcdhf90/hmout_I.f90 +++ b/src/appl/rmcdhf90/hmout_I.f90 @@ -1,14 +1,14 @@ - MODULE hmout_I + MODULE hmout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE hmout (MYID, NPROCS, NCF) - INTEGER :: MYID + SUBROUTINE hmout (MYID, NPROCS, NCF) + INTEGER :: MYID !VAST...Dummy argument MYID is not referenced in this routine. - INTEGER :: NPROCS + INTEGER :: NPROCS !VAST...Dummy argument NPROCS is not referenced in this routine. - INTEGER, INTENT(IN) :: NCF - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: NCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/improv.f90 b/src/appl/rmcdhf90/improv.f90 index 4830a8af3..67b07c7e0 100644 --- a/src/appl/rmcdhf90/improv.f90 +++ b/src/appl/rmcdhf90/improv.f90 @@ -1,14 +1,14 @@ !*********************************************************************** - SUBROUTINE IMPROV(EOL, J, LSORT, DAMPMX) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer + SUBROUTINE IMPROV(EOL, J, LSORT, DAMPMX) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE CORRE_C + USE vast_kind_param, ONLY: DOUBLE + USE CORRE_C USE damp_C USE def_C USE grid_C @@ -22,54 +22,54 @@ SUBROUTINE IMPROV(EOL, J, LSORT, DAMPMX) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cofpot_I - USE defcor_I - USE solve_I - USE orthsc_I - USE matrix_I - USE newco_I - USE setlag_I - USE quad_I - USE consis_I - USE dampck_I - USE dampor_I - USE orthy_I + USE cofpot_I + USE defcor_I + USE solve_I + USE orthsc_I + USE matrix_I + USE newco_I + USE setlag_I + USE quad_I + USE consis_I + USE dampck_I + USE dampor_I + USE orthy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - REAL(DOUBLE) , INTENT(INOUT) :: DAMPMX - LOGICAL :: EOL, LSORT + INTEGER :: J + REAL(DOUBLE) , INTENT(INOUT) :: DAMPMX + LOGICAL :: EOL, LSORT !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P2 = 2.0D-01 - REAL(DOUBLE), PARAMETER :: P005 = 5.0D-03 - REAL(DOUBLE), PARAMETER :: P0001 = 1.0D-04 + REAL(DOUBLE), PARAMETER :: P2 = 2.0D-01 + REAL(DOUBLE), PARAMETER :: P005 = 5.0D-03 + REAL(DOUBLE), PARAMETER :: P0001 = 1.0D-04 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IPR, NPTS, INV, JP, NNP, I, NWWW - REAL(DOUBLE) :: ED1, GAMAJ, ED2, WTAEV, DNORM, DNFAC, DEL1, DEL2, ODAMPJ - LOGICAL :: FAIL, FIRST + INTEGER :: IPR, NPTS, INV, JP, NNP, I, NWWW + REAL(DOUBLE) :: ED1, GAMAJ, ED2, WTAEV, DNORM, DNFAC, DEL1, DEL2, ODAMPJ + LOGICAL :: FAIL, FIRST !----------------------------------------------- ! ! C Froese Fischer's IPR and ED1 parameter ! - DATA IPR/ 0/ - DATA ED1/ 0.D0/ - DATA FIRST/ .FALSE./ + DATA IPR/ 0/ + DATA ED1/ 0.D0/ + DATA FIRST/ .FALSE./ ! ! !----------------------------------------------------------------------- - GAMAJ = GAMA(J) + GAMAJ = GAMA(J) ! ! C Froese Fischer's parameters IPR, ED1, ED2 are set and ! used in this routine and in DAMPCK ! - 1 CONTINUE - ED2 = E(J) + 1 CONTINUE + ED2 = E(J) ED1 = PED(J) ! ! Set up the exchange potential and arrays XU, XV as appropriate @@ -79,109 +79,109 @@ SUBROUTINE IMPROV(EOL, J, LSORT, DAMPMX) ! Add in Lagrange-multiplier contribution ! Add in derivative-terms contribution ! - NPTS = N - CALL COFPOT (EOL, J, NPTS) + NPTS = N + CALL COFPOT (EOL, J, NPTS) ! ! Calculate deferred corrections ! - CALL DEFCOR (J) + CALL DEFCOR (J) ! ! Solve the Dirac equation ! - INV = 0 - CALL SOLVE (J, FAIL, INV, JP, NNP) + INV = 0 + CALL SOLVE (J, FAIL, INV, JP, NNP) ! ! Upon failure issue message; take corrective action if possible ! - IF (FAIL) THEN - IF (MYID == 0) WRITE (*, 300) NP(J), NH(J), METHOD(J) - IF (METHOD(J) /= 2) THEN - METHOD(J) = 2 + IF (FAIL) THEN + IF (MYID == 0) WRITE (*, 300) NP(J), NH(J), METHOD(J) + IF (METHOD(J) /= 2) THEN + METHOD(J) = 2 !XHH orthsc does not have any argument ! Orbital J [PF() and QF()]is not updated, why redo orthogonalization - CALL ORTHSC + CALL ORTHSC !CFF ... avoid rediagonalization -! IF (EOL) THEN -! CALL MATRIX -! CALL NEWCO (WTAEV) -! ENDIF - CALL SETLAG (EOL) - GO TO 1 - ELSE - IF (MYID == 0) WRITE (*, 301) +! IF (EOL) THEN +! CALL MATRIX +! CALL NEWCO (WTAEV) +! ENDIF + CALL SETLAG (EOL) + GO TO 1 + ELSE + IF (MYID == 0) WRITE (*, 301) !CALL TIMER (0) - STOP - ENDIF - ENDIF + STOP + ENDIF + ENDIF ! ! Compute norm of radial function ! - TA(1) = 0.D0 - TA(2:MTP0) = (P(2:MTP0)**2+Q(2:MTP0)**2)*RP(2:MTP0) - MTP = MTP0 - - CALL QUAD (DNORM) - + TA(1) = 0.D0 + TA(2:MTP0) = (P(2:MTP0)**2+Q(2:MTP0)**2)*RP(2:MTP0) + MTP = MTP0 + + CALL QUAD (DNORM) + ! Determine self-consistency [multiplied by SQRT(UCF(J))] - - CALL CONSIS (J) + + CALL CONSIS (J) ! ! Normalize ! - DNFAC = 1.D0/SQRT(DNORM) - P0 = P0*DNFAC - P(:MTP0) = P(:MTP0)*DNFAC - Q(:MTP0) = Q(:MTP0)*DNFAC + DNFAC = 1.D0/SQRT(DNORM) + P0 = P0*DNFAC + P(:MTP0) = P(:MTP0)*DNFAC + Q(:MTP0) = Q(:MTP0)*DNFAC ! ! Check if different method should be used or if improvement ! count should be reduced ! - DEL1 = ABS(1.D0 - ED2/E(J)) - IF (METHOD(J) == 1) THEN - DEL2 = MAX(ABS(1.D0 - SQRT(DNORM)),ABS(DNFAC - 1.D0)) - IF (DEL1P2) THEN - METHOD(J) = 2 - GO TO 1 - ENDIF - ELSE - IF (DEL11) NSIC = NSIC - 1 - ENDIF + DEL1 = ABS(1.D0 - ED2/E(J)) + IF (METHOD(J) == 1) THEN + DEL2 = MAX(ABS(1.D0 - SQRT(DNORM)),ABS(DNFAC - 1.D0)) + IF (DEL1P2) THEN + METHOD(J) = 2 + GO TO 1 + ENDIF + ELSE + IF (DEL11) NSIC = NSIC - 1 + ENDIF ! ! Damp the orbital --- if not converged ! - IF (SCNSTY(J) > ACCY) THEN - CALL DAMPCK (IPR, J, ED1, ED2) - ODAMPJ = ABS(ODAMP(J)) - ELSE - ODAMPJ = 0.D0 ! take the whole new orbital - ENDIF - CALL DAMPOR (J, INV, ODAMPJ) - + IF (SCNSTY(J) > ACCY) THEN + CALL DAMPCK (IPR, J, ED1, ED2) + ODAMPJ = ABS(ODAMP(J)) + ELSE + ODAMPJ = 0.D0 ! take the whole new orbital + ENDIF + CALL DAMPOR (J, INV, ODAMPJ) + ! Orthogonalize all orbitals of the same kappa in the order ! fixed, spectroscopic, correlation orbitals. The order of ! orbitals in the latter two classes are sorted according ! to their self-consistency and energy. - - IF (ORTHST) THEN + + IF (ORTHST) THEN !CALL orthor (J, inv) - NWWW = NW - CALL ORTHY (NWWW, J, LSORT) - ENDIF + NWWW = NW + CALL ORTHY (NWWW, J, LSORT) + ENDIF ! ! Print details of iteration ! IF (MYID == 0) & WRITE (*, 302) NP(J),NH(J),E(J),METHOD(J),PZ(J),SCNSTY(J), & !cjb DNORM-1 -> SQRT(DNORM)-1 -!cjb DNORM - 1, ODAMPJ, JP, MF(J), INV, NNP +!cjb DNORM - 1, ODAMPJ, JP, MF(J), INV, NNP SQRT(DNORM)-1,ODAMPJ,JP,MF(J),INV,NNP - DAMPMX = MAX(DAMPMX,ABS(ODAMPJ)) - + DAMPMX = MAX(DAMPMX,ABS(ODAMPJ)) + 300 FORMAT(/,' Failure; equation for orbital ',1I2,1A2,& - ' could not be solved using method ',1I1) + ' could not be solved using method ',1I1) 301 FORMAT(/,/,' ****** Error in SUBROUTINE IMPROV ******'/,& - ' Convergence not obtained'/) + ' Convergence not obtained'/) 302 FORMAT (1X,1I2,1A2,1P,1D16.7,1x,1I2,D11.3,1D10.2,1D10.2,& 0P,F6.3,1x,1I5,1x,1I5,1x,1I2,1x,1I2) - RETURN - END SUBROUTINE IMPROV + RETURN + END SUBROUTINE IMPROV diff --git a/src/appl/rmcdhf90/improv_I.f90 b/src/appl/rmcdhf90/improv_I.f90 index 0b7a07c63..7f7258267 100644 --- a/src/appl/rmcdhf90/improv_I.f90 +++ b/src/appl/rmcdhf90/improv_I.f90 @@ -1,14 +1,14 @@ - MODULE improv_I + MODULE improv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:44:01 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:44:01 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE improv (EOL, J, LSORT, DAMPMX) - USE vast_kind_param,ONLY: DOUBLE - LOGICAL, INTENT(IN) :: EOL - INTEGER, INTENT(IN) :: J - LOGICAL :: LSORT - REAL(DOUBLE), INTENT(INOUT) :: DAMPMX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE improv (EOL, J, LSORT, DAMPMX) + USE vast_kind_param,ONLY: DOUBLE + LOGICAL, INTENT(IN) :: EOL + INTEGER, INTENT(IN) :: J + LOGICAL :: LSORT + REAL(DOUBLE), INTENT(INOUT) :: DAMPMX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/in.f90 b/src/appl/rmcdhf90/in.f90 index 8f6619f51..fe5e888d9 100644 --- a/src/appl/rmcdhf90/in.f90 +++ b/src/appl/rmcdhf90/in.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE IN(IORB, JP, P, Q, MTP) + SUBROUTINE IN(IORB, JP, P, Q, MTP) ! * ! This program computes the solution of an inhomogeneous pair of * ! radial Dirac equations in the tail region. A simple extension of * @@ -35,13 +35,13 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) ! Last update: 10 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE def_C, ONLY: accy USE grid_C, ONLY: h, n, r, rpor @@ -50,132 +50,132 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: IORB - INTEGER , INTENT(IN) :: JP - INTEGER , INTENT(OUT) :: MTP - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: IORB + INTEGER , INTENT(IN) :: JP + INTEGER , INTENT(OUT) :: MTP + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, LCNUM, MTPP1 - REAL(DOUBLE), DIMENSION(NNNP) :: TH, TI, TJ, XR, XS + INTEGER :: I, J, LCNUM, MTPP1 + REAL(DOUBLE), DIMENSION(NNNP) :: TH, TI, TJ, XR, XS REAL(DOUBLE) :: EPS, HHK, HHKF, CPJ, CMJ, CPJP1, CMJP1, TEI, TTHIS, TCI, & - TDI, TLAST - CHARACTER :: CNUM*5 + TDI, TLAST + CHARACTER :: CNUM*5 !----------------------------------------------- ! ! Global initializations ! !ww EPS = 0.1D 00*ACCY - EPS = 0.01D00*ACCY - HHK = 0.5D00*H*DBLE(NAK(IORB)) + EPS = 0.01D00*ACCY + HHK = 0.5D00*H*DBLE(NAK(IORB)) ! ! Initialize counters ! - I = 1 - J = JP + I = 1 + J = JP ! ! Other initializations ! - HHKF = HHK*RPOR(J) - CPJ = 1.0D00 + HHKF - CMJ = 1.0D00 - HHKF - HHKF = HHK*RPOR(J+1) - CPJP1 = 1.0D00 + HHKF - CMJP1 = 1.0D00 - HHKF + HHKF = HHK*RPOR(J) + CPJ = 1.0D00 + HHKF + CMJ = 1.0D00 - HHKF + HHKF = HHK*RPOR(J+1) + CPJP1 = 1.0D00 + HHKF + CMJP1 = 1.0D00 - HHKF ! ! Compute required elements of first two rows of L and U ! - TH(I) = CPJ - TEI = -TF(J)/TH(I) - TI(I) = (-CPJP1) + TEI*TG(J+1) - TJ(I) = CMJP1*TEI - TF(J+1) + TH(I) = CPJ + TEI = -TF(J)/TH(I) + TI(I) = (-CPJP1) + TEI*TG(J+1) + TJ(I) = CMJP1*TEI - TF(J+1) ! ! First elements of solution vector Z ! - XR(I) = (-XV(J)) + TG(J)*P(J) - XS(I) = (-XU(J)) - CMJ*P(J) - TEI*XR(I) + XR(I) = (-XV(J)) + TG(J)*P(J) + XS(I) = (-XU(J)) - CMJ*P(J) - TEI*XR(I) ! - TTHIS = ABS(XS(I)/TI(I)) + TTHIS = ABS(XS(I)/TI(I)) ! - 1 CONTINUE - I = I + 1 - J = J + 1 + 1 CONTINUE + I = I + 1 + J = J + 1 ! ! Failure if tables not long enough ! - IF (J >= N) THEN - CALL CONVRT (N, CNUM, LCNUM) - WRITE (6, *) 'IN: maximum tabulation point exceeds' - WRITE (6, *) ' dimensional limit (currently '//CNUM(1:LCNUM)//');' - WRITE (6, *) ' radial wavefunction may indicate a' - WRITE (6, *) ' continuum state.' - STOP - ENDIF + IF (J >= N) THEN + CALL CONVRT (N, CNUM, LCNUM) + WRITE (6, *) 'IN: maximum tabulation point exceeds' + WRITE (6, *) ' dimensional limit (currently '//CNUM(1:LCNUM)//');' + WRITE (6, *) ' radial wavefunction may indicate a' + WRITE (6, *) ' continuum state.' + STOP + ENDIF ! ! Compute required elements of remaining rows of L and U ! - CPJ = CPJP1 - CMJ = CMJP1 - HHKF = HHK*RPOR(J+1) - CPJP1 = 1.0D00 + HHKF - CMJP1 = 1.0D00 - HHKF + CPJ = CPJP1 + CMJ = CMJP1 + HHKF = HHK*RPOR(J+1) + CPJP1 = 1.0D00 + HHKF + CMJP1 = 1.0D00 - HHKF ! - TCI = -TG(J)/TI(I-1) - TH(I) = CPJ - TCI*TJ(I-1) - TDI = CMJ/TI(I-1) - TEI = ((-TF(J))-TDI*TJ(I-1))/TH(I) - TI(I) = (-CPJP1) + TEI*TG(J+1) - TJ(I) = (-TF(J+1)) + CMJP1*TEI + TCI = -TG(J)/TI(I-1) + TH(I) = CPJ - TCI*TJ(I-1) + TDI = CMJ/TI(I-1) + TEI = ((-TF(J))-TDI*TJ(I-1))/TH(I) + TI(I) = (-CPJP1) + TEI*TG(J+1) + TJ(I) = (-TF(J+1)) + CMJP1*TEI ! ! Solution of L*Z = V ! - XR(I) = (-XV(J)) - TCI*XS(I-1) - XS(I) = (-XU(J)) - TDI*XS(I-1) - TEI*XR(I) + XR(I) = (-XV(J)) - TCI*XS(I-1) + XS(I) = (-XU(J)) - TDI*XS(I-1) - TEI*XR(I) ! ! Test for outer boundary ! - TLAST = TTHIS - TTHIS = ABS(XS(I)/TI(I)) - IF (TTHIS + TLAST <= EPS) THEN - MTP = J - ELSE - GO TO 1 - ENDIF + TLAST = TTHIS + TTHIS = ABS(XS(I)/TI(I)) + IF (TTHIS + TLAST <= EPS) THEN + MTP = J + ELSE + GO TO 1 + ENDIF ! ! Reset counter ! - I = I - 1 + I = I - 1 ! ! Last two rows of solution of U*W = Z ; evaluation of Q(J) ! - Q(J) = 0.0D00 - P(J) = XS(I)/TI(I) - Q(J-1) = (XR(I)+TG(J)*P(J))/TH(I) + Q(J) = 0.0D00 + P(J) = XS(I)/TI(I) + Q(J-1) = (XR(I)+TG(J)*P(J))/TH(I) ! ! Solution of U*W = Z ! - 2 CONTINUE - J = J - 1 - I = I - 1 + 2 CONTINUE + J = J - 1 + I = I - 1 ! - IF (I > 0) THEN - P(J) = (XS(I)-TJ(I)*Q(J))/TI(I) - Q(J-1) = (XR(I)+(1.0D00-HHK*RPOR(J))*Q(J)+TG(J)*P(J))/TH(I) - GO TO 2 - ENDIF + IF (I > 0) THEN + P(J) = (XS(I)-TJ(I)*Q(J))/TI(I) + Q(J-1) = (XR(I)+(1.0D00-HHK*RPOR(J))*Q(J)+TG(J)*P(J))/TH(I) + GO TO 2 + ENDIF ! ! Complete tables with zeroes ! - MTPP1 = MTP + 1 - P(MTPP1:N) = 0.0D00 - Q(MTPP1:N) = 0.0D00 + MTPP1 = MTP + 1 + P(MTPP1:N) = 0.0D00 + Q(MTPP1:N) = 0.0D00 ! - RETURN - END SUBROUTINE IN + RETURN + END SUBROUTINE IN diff --git a/src/appl/rmcdhf90/in_I.f90 b/src/appl/rmcdhf90/in_I.f90 index aeda6034e..b1661f8ea 100644 --- a/src/appl/rmcdhf90/in_I.f90 +++ b/src/appl/rmcdhf90/in_I.f90 @@ -1,16 +1,16 @@ - MODULE in_I + MODULE in_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE in (IORB, JP, P, Q, MTP) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE in (IORB, JP, P, Q, MTP) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - integer, INTENT(IN) :: IORB - integer, INTENT(IN) :: JP - real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q - integer, INTENT(OUT) :: MTP - END SUBROUTINE - END INTERFACE - END MODULE + integer, INTENT(IN) :: IORB + integer, INTENT(IN) :: JP + real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + integer, INTENT(OUT) :: MTP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/ispar.f90 b/src/appl/rmcdhf90/ispar.f90 index 93cd281a9..4429c27ab 100644 --- a/src/appl/rmcdhf90/ispar.f90 +++ b/src/appl/rmcdhf90/ispar.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ISPAR (ICSF) + INTEGER FUNCTION ISPAR (ICSF) ! * ! ISPAR is the value of P for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ISPAR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA @@ -20,15 +20,15 @@ INTEGER FUNCTION ISPAR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- !----------------------------------------------- ! ispar = jcupa(NNNW,icsf) - IF (ISPAR > 127) ISPAR = ISPAR - 256 - ISPAR = SIGN(1,ISPAR) + IF (ISPAR > 127) ISPAR = ISPAR - 256 + ISPAR = SIGN(1,ISPAR) ! - RETURN - END FUNCTION ISPAR + RETURN + END FUNCTION ISPAR diff --git a/src/appl/rmcdhf90/ispar_I.f90 b/src/appl/rmcdhf90/ispar_I.f90 index 06b3639b5..79ace3629 100644 --- a/src/appl/rmcdhf90/ispar_I.f90 +++ b/src/appl/rmcdhf90/ispar_I.f90 @@ -1,10 +1,10 @@ - MODULE ispar_I + MODULE ispar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ispar (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ispar (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/itjpo.f90 b/src/appl/rmcdhf90/itjpo.f90 index 941c725f8..355c5744e 100644 --- a/src/appl/rmcdhf90/itjpo.f90 +++ b/src/appl/rmcdhf90/itjpo.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITJPO (ICSF) + INTEGER FUNCTION ITJPO (ICSF) ! * ! ITJPO is the value of 2J+1 for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ITJPO (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA @@ -20,10 +20,10 @@ INTEGER FUNCTION ITJPO (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- itjpo = jcupa(NNNW,icsf) - IF (ITJPO > 127) ITJPO = 256 - ITJPO + IF (ITJPO > 127) ITJPO = 256 - ITJPO ITJPO = IABS (ITJPO) - RETURN - END FUNCTION ITJPO + RETURN + END FUNCTION ITJPO diff --git a/src/appl/rmcdhf90/itjpo_I.f90 b/src/appl/rmcdhf90/itjpo_I.f90 index e74342cdf..7d89b5ca8 100644 --- a/src/appl/rmcdhf90/itjpo_I.f90 +++ b/src/appl/rmcdhf90/itjpo_I.f90 @@ -1,10 +1,10 @@ - MODULE itjpo_I + MODULE itjpo_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itjpo (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION itjpo (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/lagcon.f90 b/src/appl/rmcdhf90/lagcon.f90 index 1d688cace..2730bcb1c 100644 --- a/src/appl/rmcdhf90/lagcon.f90 +++ b/src/appl/rmcdhf90/lagcon.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LAGCON(J, NPROCS) + SUBROUTINE LAGCON(J, NPROCS) ! * ! This routine includes the Lagrange multiplier contribution in * ! the 'exchange' term. * @@ -12,13 +12,13 @@ SUBROUTINE LAGCON(J, NPROCS) ! Modified by Xinghong He Last update: 17 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE def_C USE grid_C @@ -30,57 +30,57 @@ SUBROUTINE LAGCON(J, NPROCS) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: NPROCS + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: NPROCS !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IECCK, L1, L2, M, MFM, I - REAL(DOUBLE) :: EPS, WB, WA, WARI + INTEGER :: K, IECCK, L1, L2, M, MFM, I + REAL(DOUBLE) :: EPS, WB, WA, WARI !----------------------------------------------- ! ! - IF (NEC == 0) RETURN + IF (NEC == 0) RETURN ! !ww EPS = ACCY*0.1D 00 - EPS = ACCY*0.01D00 + EPS = ACCY*0.01D00 ! ! Add contributions from off-diagonal parameters to exchange ! - WB = 1.0D00/(UCF(J)*C)/NPROCS - DO K = 1, NEC + WB = 1.0D00/(UCF(J)*C)/NPROCS + DO K = 1, NEC ! ! Decode index ! - IECCK = IECC(K) - L1 = IECCK/KEY - L2 = IECCK - KEY*L1 + IECCK = IECC(K) + L1 = IECCK/KEY + L2 = IECCK - KEY*L1 ! - IF (J == L1) THEN - M = L2 - ELSE IF (J == L2) THEN - M = L1 - ELSE - CYCLE - ENDIF + IF (J == L1) THEN + M = L2 + ELSE IF (J == L2) THEN + M = L1 + ELSE + CYCLE + ENDIF ! - WA = ECV(K)*WB - IF (ABS(WA) < EPS) CYCLE + WA = ECV(K)*WB + IF (ABS(WA) < EPS) CYCLE ! ! ADD CONTRIBUTIONS TO EXCHANGE TERMS ! - MFM = MF(M) - DO I = 1, MFM - WARI = WA*R(I) - XP(I) = XP(I) + WARI*QF(I,M) - XQ(I) = XQ(I) - WARI*PF(I,M) - END DO + MFM = MF(M) + DO I = 1, MFM + WARI = WA*R(I) + XP(I) = XP(I) + WARI*QF(I,M) + XQ(I) = XQ(I) - WARI*PF(I,M) + END DO ! - END DO + END DO ! - RETURN - END SUBROUTINE LAGCON + RETURN + END SUBROUTINE LAGCON diff --git a/src/appl/rmcdhf90/lagcon_I.f90 b/src/appl/rmcdhf90/lagcon_I.f90 index bceed3274..5c5105277 100644 --- a/src/appl/rmcdhf90/lagcon_I.f90 +++ b/src/appl/rmcdhf90/lagcon_I.f90 @@ -1,11 +1,11 @@ - MODULE lagcon_I + MODULE lagcon_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lagcon (J, NPROCS) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: NPROCS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lagcon (J, NPROCS) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: NPROCS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/lodcsh2GG.f90 b/src/appl/rmcdhf90/lodcsh2GG.f90 old mode 100755 new mode 100644 index 29cde3e64..4275ce83e --- a/src/appl/rmcdhf90/lodcsh2GG.f90 +++ b/src/appl/rmcdhf90/lodcsh2GG.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) + SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! ! IMPORTANT: ! ========== @@ -30,73 +30,73 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C + USE DEBUG_C + USE DEF_C USE ORB_C, ncfblock => ncf USE SYMA_C, ONLY: JPGG - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrcn_I - USE parsjl_I + USE prsrcn_I + USE parsjl_I USE pack_I - USE convrt_I - USE iq_I - USE jqs_I - USE jcup_I + USE convrt_I + USE iq_I + USE jqs_I + USE jcup_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER :: NCORE - INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NFILE + INTEGER :: NCORE + INTEGER, INTENT(IN) :: JB !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: LOADALL = -119 - CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: LOADALL = -119 + CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER, DIMENSION(NW2) :: IQSUB - INTEGER, DIMENSION(NNNW) :: JX + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER, DIMENSION(NW2) :: IQSUB + INTEGER, DIMENSION(NNNW) :: JX INTEGER :: NCORP1, NREC, NCF, NPEEL, I, J INTEGER :: IOS, IERR, LOC, NQS, ISPARC, NJX, IOC, IPTY INTEGER :: NQSN, NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI INTEGER :: NKJI, IFULLI, NU, JSUB, IQT, NBEG, NEND INTEGER :: LENTH, JXN, JPI, NCOREL, IQGG, JBGG, NCFGG - LOGICAL :: EMPTY, FULL - CHARACTER :: STR*256, RECL + LOGICAL :: EMPTY, FULL + CHARACTER :: STR*256, RECL !----------------------------------------------- ! - IF (JB /= LOADALL) THEN - WRITE (6, *) 'Loading CSF File for block ', JB - ELSE - WRITE (6, *) 'Loading CSF File for ALL blocks ' - ENDIF - - NCORP1 = NCORE + 1 - NPEEL = NW - NCORE + IF (JB /= LOADALL) THEN + WRITE (6, *) 'Loading CSF File for block ', JB + ELSE + WRITE (6, *) 'Loading CSF File for ALL blocks ' + ENDIF + + NCORP1 = NCORE + 1 + NPEEL = NW - NCORE ! ! NPEEL is used as 1) number of peel orbitals (here) and ! 2) number of peel electrons (later in this routine) ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -106,13 +106,13 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! ! Zero out the arrays that store packed integers - only when ncfblock>0 ! - IQA(:NNNW,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,1,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,2,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,3,:NCFBLOCK) = 0 -!GG JCUPA(:NNNW,:NCFBLOCK) = 0 - - NCF = 0 + IQA(:NNNW,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,1,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,2,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,3,:NCFBLOCK) = 0 +!GG JCUPA(:NNNW,:NCFBLOCK) = 0 + + NCF = 0 !GGGG NCFGG = 0 JBGG = 1 @@ -122,8 +122,8 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) !GG NCF = NCF + 1 !GGGG ! - READ (NFILE, '(A)', IOSTAT=IOS) STR - + READ (NFILE, '(A)', IOSTAT=IOS) STR + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This IF...READ makes the routine load the entire file (all blocks) ! by ignoring the end-of-block mark @@ -137,342 +137,342 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) NCFGG = 1 JBGG = JBGG + 1 END IF -!GGGG +!GGGG !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (IOS==0 .AND. STR(1:2)/=' *') THEN + + IF (IOS==0 .AND. STR(1:2)/=' *') THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (STR, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 28 + CALL PRSRCN (STR, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 28 ! ! Read the J_sub and v quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting subshell quantum', & - ' number specification;' - GO TO 27 - ENDIF - LOC = LEN_TRIM(STR) - CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 27 + ' number specification;' + GO TO 27 + ENDIF + LOC = LEN_TRIM(STR) + CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 27 ! ! Read the X, J, and (sign of) P quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Zero out the arrays that store packed integers ! - IQA(:NNNW,NCF) = 0 -!GG JQSA(:NNNW,1,NCF) = 0 -!GG JQSA(:NNNW,2,NCF) = 0 -!GG JQSA(:NNNW,3,NCF) = 0 -!GG JCUPA(:NNNW,NCF) = 0 + IQA(:NNNW,NCF) = 0 +!GG JQSA(:NNNW,1,NCF) = 0 +!GG JQSA(:NNNW,2,NCF) = 0 +!GG JQSA(:NNNW,3,NCF) = 0 +!GG JCUPA(:NNNW,NCF) = 0 ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - LOC = LEN_TRIM(STR) - RECL = STR(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + LOC = LEN_TRIM(STR) + RECL = STR(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) MYNAME//': Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) -!GG CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) +!GG CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': Subshell quantum numbers ', & 'specified incorrectly for '//STR(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) MYNAME//': Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': coupling of '//STR(1:LENTH)//& - NH(I), ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE -!GG CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) -!GG CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) -!GG CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! -!GG DO I = MAX(1,NOPEN), NW -!GG CALL PACK (0, I, JCUPA(1:NNNW,NCF)) -!GG END DO -! - IF (NQSN /= NQS) THEN + NH(I), ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE +!GG CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) +!GG CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) +!GG CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! +!GG DO I = MAX(1,NOPEN), NW +!GG CALL PACK (0, I, JCUPA(1:NNNW,NCF)) +!GG END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) MYNAME//': Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) MYNAME//': Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) MYNAME//': Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY + JPI = (JLAST + 1)*IPTY !GGGG IF(NCFGG .EQ. 1) THEN JPGG(JBGG) = JPI END IF -!GG CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) +!GG CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) !GGGG ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) MYNAME//': Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! -!GG IF (NCF > 1) THEN -!GG DO J = 1, NCF - 1 -!GG DO I = NCORP1, NW -!GG IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 -!GG IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 -!GG IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 -!GG IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 -!GG END DO -!GG DO I = 1, NOPEN - 1 -!GG IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 -!GG END DO -!GG END DO -!GG WRITE (ISTDE, *) MYNAME//': Repeated CSF;' -!GG GO TO 26 -!GG ENDIF +!GG IF (NCF > 1) THEN +!GG DO J = 1, NCF - 1 +!GG DO I = NCORP1, NW +!GG IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 +!GG IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 +!GG IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 +!GG IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 +!GG END DO +!GG DO I = 1, NOPEN - 1 +!GG IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 +!GG END DO +!GG END DO +!GG WRITE (ISTDE, *) MYNAME//': Repeated CSF;' +!GG GO TO 26 +!GG ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + + GO TO 3 ! - ELSE ! the record just read is either ' *' or EOF, marking + ELSE ! the record just read is either ' *' or EOF, marking ! the end of a block or end of the file ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) -!GG CALL PACK (0, I, JQSA(1:NNNW,1,1)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,1)) -!GG CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO -!GG CALL PACK (0, 1, JCUPA(1:NNNW,1)) -!GG CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF - - IF (NCF /= NCFBLOCK) THEN - WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK - STOP - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) +!GG CALL PACK (0, I, JQSA(1:NNNW,1,1)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,1)) +!GG CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO +!GG CALL PACK (0, 1, JCUPA(1:NNNW,1)) +!GG CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF + + IF (NCF /= NCFBLOCK) THEN + WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK + STOP + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), STR, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (6, *) 'Subshell '//STR(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs' - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ' in all CSFs' + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! This will act as a check now - it's been determined in lodcsh ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) ! NELEC = NCOREL+NPEEL - IF (NCOREL + NPEEL /= NELEC) THEN - WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' - STOP - ENDIF + IF (NCOREL + NPEEL /= NELEC) THEN + WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' + STOP + ENDIF WRITE (6,*)'There are ',NCF,' relativistic CSFs... load complete;' - RETURN -! - 26 CONTINUE - BACKSPACE (NFILE) - 27 CONTINUE - BACKSPACE (NFILE) - 28 CONTINUE - BACKSPACE (NFILE) - WRITE (ISTDE, *) ' CSF sequence number: ', NCF - DO I = 1, 3 + RETURN +! + 26 CONTINUE + BACKSPACE (NFILE) + 27 CONTINUE + BACKSPACE (NFILE) + 28 CONTINUE + BACKSPACE (NFILE) + WRITE (ISTDE, *) ' CSF sequence number: ', NCF + DO I = 1, 3 READ (nfile,'(A)',ERR = 29,END = 29) str - WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) - END DO + WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) + END DO 29 continue - CLOSE(NFILE) - - STOP + CLOSE(NFILE) + + STOP END SUBROUTINE LODCSH2GG diff --git a/src/appl/rmcdhf90/lodcsh2GG_I.f90 b/src/appl/rmcdhf90/lodcsh2GG_I.f90 old mode 100755 new mode 100644 index 33deeac03..47e0befad --- a/src/appl/rmcdhf90/lodcsh2GG_I.f90 +++ b/src/appl/rmcdhf90/lodcsh2GG_I.f90 @@ -1,12 +1,12 @@ - MODULE lodcsh2GG_I + MODULE lodcsh2GG_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcsh2GG(NFILE, NCORE, JB) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(OUT) :: NCORE + SUBROUTINE lodcsh2GG(NFILE, NCORE, JB) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(OUT) :: NCORE INTEGER , INTENT(IN) :: JB - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/maneig.f90 b/src/appl/rmcdhf90/maneig.f90 index daf7fb42a..d71aa3c26 100644 --- a/src/appl/rmcdhf90/maneig.f90 +++ b/src/appl/rmcdhf90/maneig.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE MANEIG(dvdfirst, LPRINT, JBLOCK, & - NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) ! * ! This module manages the operation of the eigensolvers and the * ! storage of the eigenpairs. There are two principal branches: * @@ -32,41 +32,41 @@ SUBROUTINE MANEIG(dvdfirst, LPRINT, JBLOCK, & ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE DEF_C + USE DEF_C USE eigv_C USE hblock_C USE hmat_C USE mpi_s USE orb_C - USE WCHBLK_C, JBLOCKK=>JBLOCK - USE WHERE_C + USE WCHBLK_C, JBLOCKK=>JBLOCK + USE WHERE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE spicmv2_I - USE iniest2_I - USE gdvd_I - USE itjpo_I - USE ispar_I + USE spicmv2_I + USE iniest2_I + USE gdvd_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- logical, INTENT(IN) :: dvdfirst - INTEGER :: JBLOCK - INTEGER, INTENT(IN) :: NCFPAT - INTEGER, INTENT(IN) :: NCMINPAT - INTEGER, INTENT(IN) :: NEVECPAT - INTEGER :: NCFTOT - LOGICAL :: LPRINT + INTEGER :: JBLOCK + INTEGER, INTENT(IN) :: NCFPAT + INTEGER, INTENT(IN) :: NCMINPAT + INTEGER, INTENT(IN) :: NEVECPAT + INTEGER :: NCFTOT + LOGICAL :: LPRINT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -74,24 +74,24 @@ SUBROUTINE MANEIG(dvdfirst, LPRINT, JBLOCK, & ILOW, IHIGH, LIWORK, IC, NLOOPS, NMV, NEND, J, JSTATE, & IOFSET, I, IA, IERR INTEGER, DIMENSION(:), POINTER :: IWORK, JWORK - REAL(DOUBLE) :: PNWORK, CRITE, CRITC, CRITR, ORTHO, AMAX, WA, DNFAC + REAL(DOUBLE) :: PNWORK, CRITE, CRITC, CRITR, ORTHO, AMAX, WA, DNFAC REAL(DOUBLE), DIMENSION(:), POINTER :: WORK, DIAG - LOGICAL :: HIEND + LOGICAL :: HIEND !----------------------------------------------- !PRINT *, 'maneig ...' - + ! ...spicmv2 needs this COMMON /WCHBLK/JBLOCKK - JBLOCKK = JBLOCK + JBLOCKK = JBLOCK ! !======================================================================= ! Trivial case !======================================================================= - IF (NCF == 1) THEN - EVAL(NCMINPAT+1) = 0.D0 - EVEC(NEVECPAT+1) = 1.D0 - GO TO 123 ! Don't like big ELSE - ENDIF + IF (NCF == 1) THEN + EVAL(NCMINPAT+1) = 0.D0 + EVEC(NEVECPAT+1) = 1.D0 + GO TO 123 ! Don't like big ELSE + ENDIF ! !======================================================================= ! Non-trivial case - Use Davidson eigensolver @@ -101,24 +101,24 @@ SUBROUTINE MANEIG(dvdfirst, LPRINT, JBLOCK, & ! the expression below; the value of LIM can be reduced to NVECT ! plus a smaller number if storage is severely constrained ! - NVECT = NCMAXBLK(JBLOCK) - LIM = MIN(NCF,2*NVECT + 40) - LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECT - CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') - + NVECT = NCMAXBLK(JBLOCK) + LIM = MIN(NCF,2*NVECT + 40) + LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECT + CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG') + !...At most 14 ? restriction removed xhh 98-05-19 !nvex = MIN (nvect,ncfblk(jblock),14) - NVEX = MIN(NVECT,NCFBLK(JBLOCK)) - NIV = NVEX - MAXITR = MIN(NVECT*200,NCF) -! N1000 = 2000 - N1000 = 4000 + NVEX = MIN(NVECT,NCFBLK(JBLOCK)) + NIV = NVEX + MAXITR = MIN(NVECT*200,NCF) +! N1000 = 2000 + N1000 = 4000 ! ! Initial estimates for eigenvectors ! !CFF if (dvdfirst .or. (ncf .LE. n1000) ) then - CALL INIEST2 (N1000, NCF, NIV, WORK, EMT, IENDC, IROW) + CALL INIEST2 (N1000, NCF, NIV, WORK, EMT, IENDC, IROW) else !CFF .. use current estimates nend = ncf * nvex @@ -128,100 +128,100 @@ SUBROUTINE MANEIG(dvdfirst, LPRINT, JBLOCK, & work( ncf*(iccmin(j+ncminpat)-1) + 1 ), 1) ENDDO ENDIF - + ! iniest2 looks for eigenvectors of n1000*n1000 matrix so there ! is no need to call dvdson if block size <= n1000 - - IF (NCF > N1000) THEN - WRITE (*, *) 'Calling dvdson!!!', MAXITR - + + IF (NCF > N1000) THEN + WRITE (*, *) 'Calling dvdson!!!', MAXITR + ! Call Davidson eigensolver - - MBLOCK = 1 - ILOW = 1 - IHIGH = NVEX - LIWORK = 6*LIM + NVECT - CRITE = 1.0D-17 -! CRITC = 1.0D-08 -! CRITR = 1.0D-08 -! ORTHO = MAX(1D-8,CRITR) + + MBLOCK = 1 + ILOW = 1 + IHIGH = NVEX + LIWORK = 6*LIM + NVECT + CRITE = 1.0D-17 +! CRITC = 1.0D-08 +! CRITR = 1.0D-08 +! ORTHO = MAX(1D-8,CRITR) critc = 1.0D-09 critr = 1.0D-09 ortho = MAX (1D-9, critr) ! ! Store the diagonals in a separate array and make it global ! - CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIG') - - DO IC = MYID + 1, NCF, NPROCS - DIAG(IC) = EMT(IENDC(IC)) - END DO - - CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') - CALL ALLOC (JWORK, LIM, 'JWORK', 'MANEIG') + CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIG') + + DO IC = MYID + 1, NCF, NPROCS + DIAG(IC) = EMT(IENDC(IC)) + END DO + + CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG') + CALL ALLOC (JWORK, LIM, 'JWORK', 'MANEIG') CALL GDVD (SPICMV2, NCF, LIM, DIAG, ILOW, IHIGH, JWORK, NIV, MBLOCK, & CRITE, CRITC, CRITR, ORTHO, MAXITR, WORK, LWORK, IWORK, LIWORK, & - HIEND, NLOOPS, NMV, IERR) - - CALL DALLOC (DIAG, 'DIAG', 'MANEIG') - CALL DALLOC (IWORK, 'IWORK', 'MANEIG') - CALL DALLOC (JWORK, 'JWORK', 'MANEIG') - - WRITE (*, 301) NLOOPS, NMV - IF (IERR /= 0) WRITE (*, 302) IERR - ENDIF + HIEND, NLOOPS, NMV, IERR) + + CALL DALLOC (DIAG, 'DIAG', 'MANEIG') + CALL DALLOC (IWORK, 'IWORK', 'MANEIG') + CALL DALLOC (JWORK, 'JWORK', 'MANEIG') + + WRITE (*, 301) NLOOPS, NMV + IF (IERR /= 0) WRITE (*, 302) IERR + ENDIF ! ! Pick up the eigen pairs and store in EVAL and EVEC ! - NEND = NCF*NVEX - DO J = 1, NEVBLK(JBLOCK) - EVAL(NCMINPAT+J) = WORK(NEND + ICCMIN(J + NCMINPAT)) + NEND = NCF*NVEX + DO J = 1, NEVBLK(JBLOCK) + EVAL(NCMINPAT+J) = WORK(NEND + ICCMIN(J + NCMINPAT)) CALL DCOPY (NCF, WORK(NCF*(ICCMIN(J + NCMINPAT) - 1) + 1), 1, EVEC(& - NEVECPAT+NCF*(J-1)+1), 1) - END DO + NEVECPAT+NCF*(J-1)+1), 1) + END DO ! print *, ncminpat,(eval(ncminpat+j),j=1,nevblk(jblock)), ! 1 'zou,from maneig' ! ! Deallocate storage ! - CALL DALLOC (WORK, 'WORK', 'MANEIG') - - 123 CONTINUE - DO JSTATE = 1, NEVBLK(JBLOCK) + CALL DALLOC (WORK, 'WORK', 'MANEIG') + + 123 CONTINUE + DO JSTATE = 1, NEVBLK(JBLOCK) ! ! Find the dominant component of each eigenvector ! - IOFSET = NEVECPAT + NCF*(JSTATE - 1) - - AMAX = 0.D0 - DO I = 1, NCF - WA = ABS(EVEC(I+IOFSET)) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO + IOFSET = NEVECPAT + NCF*(JSTATE - 1) + + AMAX = 0.D0 + DO I = 1, NCF + WA = ABS(EVEC(I+IOFSET)) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO ! ! Find the angular momentum and parity of the dominant component ! -!GG IATJPO(JSTATE+NCMINPAT) = ITJPO(IA + NCFPAT) -!GG IASPAR(JSTATE+NCMINPAT) = ISPAR(IA + NCFPAT) +!GG IATJPO(JSTATE+NCMINPAT) = ITJPO(IA + NCFPAT) +!GG IASPAR(JSTATE+NCMINPAT) = ISPAR(IA + NCFPAT) ! ! Redefine eigenvectors so that the dominant component ! is positive ! - IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE - DNFAC = -1.D0 - CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) + IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE + DNFAC = -1.D0 + CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) !=============================================================== - - END DO - - 301 FORMAT('DVDSON: ',1I3,' loops; ',1I3,' matrix-vector multiplies.') - 302 FORMAT(' Returned from DVDSON with IERR = ',1I4) + + END DO + + 301 FORMAT('DVDSON: ',1I3,' loops; ',1I3,' matrix-vector multiplies.') + 302 FORMAT(' Returned from DVDSON with IERR = ',1I4) 303 FORMAT(/,' ***** WARNING *****'/,/,& ' The angular momentum and parity of level ',1I2,' have changed:'/,& ' Last iteration: (2J+1) = ',1I2,', parity = ',1I2,';'/,& - ' this iteration: (2J+1) = ',1I2,', parity = ',1I2,'.') - - RETURN - END SUBROUTINE MANEIG + ' this iteration: (2J+1) = ',1I2,', parity = ',1I2,'.') + + RETURN + END SUBROUTINE MANEIG diff --git a/src/appl/rmcdhf90/maneig_I.f90 b/src/appl/rmcdhf90/maneig_I.f90 index 03be323b1..349a8ab6c 100644 --- a/src/appl/rmcdhf90/maneig_I.f90 +++ b/src/appl/rmcdhf90/maneig_I.f90 @@ -1,17 +1,17 @@ - MODULE maneig_I + MODULE maneig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:49:56 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:49:56 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maneig (dvdfirst,LPRINT, JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + SUBROUTINE maneig (dvdfirst,LPRINT, JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) logical, INTENT(IN) :: dvdfirst - LOGICAL :: LPRINT + LOGICAL :: LPRINT !VAST...Dummy argument LPRINT is not referenced in this routine. - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: NCFPAT - INTEGER, INTENT(IN) :: NCMINPAT - INTEGER, INTENT(IN) :: NEVECPAT - INTEGER :: NCFTOT - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: NCFPAT + INTEGER, INTENT(IN) :: NCMINPAT + INTEGER, INTENT(IN) :: NEVECPAT + INTEGER :: NCFTOT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/matrix.f90 b/src/appl/rmcdhf90/matrix.f90 index 33d06b592..887f00d5c 100644 --- a/src/appl/rmcdhf90/matrix.f90 +++ b/src/appl/rmcdhf90/matrix.f90 @@ -18,22 +18,22 @@ SUBROUTINE MATRIX(dvdfirst) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE damp_C USE def_C, ONLY: iccmin, ncmin, ncmax - USE DEBUG_C + USE DEBUG_C USE eigv_C USE hblock_C USE hmat_C USE iounit_C - USE MCPA_C + USE MCPA_C USE mpi_s USE orb_C USE pos_C @@ -42,8 +42,8 @@ SUBROUTINE MATRIX(dvdfirst) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setham_I - USE maneig_I + USE setham_I + USE maneig_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -58,221 +58,221 @@ SUBROUTINE MATRIX(dvdfirst) REAL(DOUBLE), DIMENSION(:), POINTER :: CMVL REAL(DOUBLE) :: amax, cdampj, dnfac, evecij, sum, tmp, omcdaj, ovrlap, wa INTEGER, EXTERNAL :: ddot - LOGICAL :: FIRST - CHARACTER :: MCPLAB*3 + LOGICAL :: FIRST + CHARACTER :: MCPLAB*3 - SAVE FIRST + SAVE FIRST ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! POINTER (cmvl(1)) ! !----------------------------------------------------------------------- - - IF (MYID == 0) WRITE (6, *) - + + IF (MYID == 0) WRITE (6, *) + ! Allocate memory for CMVL once (the maximum size) ! Save previous estimate of eigenvectors - - IF (.NOT.FIRST) THEN - CALL ALLOC (CMVL, NVECSIZ, 'CMVL', 'MATRIX') - CALL DCOPY (NVECSIZ, EVEC, 1, CMVL, 1) - ENDIF - + + IF (.NOT.FIRST) THEN + CALL ALLOC (CMVL, NVECSIZ, 'CMVL', 'MATRIX') + CALL DCOPY (NVECSIZ, EVEC, 1, CMVL, 1) + ENDIF + !======================================================================= ! Position the files - MCP files (unit NFILE) for reading ! and mixing coefficients file (unit 25) for writing !======================================================================= - DO NFILE = 30, 32 + KMAXF - REWIND (NFILE) - IF (NFILE == 30) THEN - READ (NFILE) - READ (NFILE) - READ (NFILE) - ENDIF - READ (NFILE) - READ (NFILE) - READ (NFILE) - END DO - + DO NFILE = 30, 32 + KMAXF + REWIND (NFILE) + IF (NFILE == 30) THEN + READ (NFILE) + READ (NFILE) + READ (NFILE) + ENDIF + READ (NFILE) + READ (NFILE) + READ (NFILE) + END DO + ! To put in ncmin and nvecsiz. Values read here are the same ! as those from elsewhere (shch as common blocks) - IF (MYID == 0) THEN - REWIND (25) - READ (25) ! 'G92MIX' - READ (25) NELEC, NCFTOT, NW, NTMP, NTMP, NBLOCK - BACKSPACE (25) - WRITE (25) NELEC, NCFTOT, NW, NCMIN, NVECSIZ, NBLOCK - ENDIF - + IF (MYID == 0) THEN + REWIND (25) + READ (25) ! 'G92MIX' + READ (25) NELEC, NCFTOT, NW, NTMP, NTMP, NBLOCK + BACKSPACE (25) + WRITE (25) NELEC, NCFTOT, NW, NCMIN, NVECSIZ, NBLOCK + ENDIF + !======================================================================= ! Do the job block by block !======================================================================= - + !------------------------------------------------ - DO JBLOCK = 1, NBLOCK ! block do-loop + DO JBLOCK = 1, NBLOCK ! block do-loop !------------------------------------------------ - + !======================================================================= ! Read indeces of non-zero elements from mcp.30 file. Note the ! format has been changed to lower-triangle-by-rows. ! Length of iendc can be reduced !======================================================================= - - READ (30) MCPLAB, JBLOCKT, NCF + + READ (30) MCPLAB, JBLOCKT, NCF IF (JBLOCKT/=JBLOCK .OR. NCF/=NCFBLK(JBLOCK)) STOP & - 'matrx: jblockt .NE. jblock .OR. ncf1 .NE. ncf2' + 'matrx: jblockt .NE. jblock .OR. ncf1 .NE. ncf2' READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'MATRIX') - CALL ALLOC (EMT, NELMNT, 'EMT', 'MATRIX') + CALL ALLOC (IROW, NELMNT, 'IROW', 'MATRIX') + CALL ALLOC (EMT, NELMNT, 'EMT', 'MATRIX') !cjb ALLOC (IENDC, NCF + 1,...) -> ALLOC (IENDC, 0, NCF,...) -!cjb CALL ALLOC (IENDC, NCF + 1, 'IENDC', 'MATRIX' ) - CALL ALLOC (IENDC, 0, NCF, 'IENDC', 'MATRIX' ) - +!cjb CALL ALLOC (IENDC, NCF + 1, 'IENDC', 'MATRIX' ) + CALL ALLOC (IENDC, 0, NCF, 'IENDC', 'MATRIX' ) + ! ! may not be necessary if iendc is ALWAYS used - IENDC(0:NCF) = 0 ! the way it is assigned here. - + IENDC(0:NCF) = 0 ! the way it is assigned here. + !...EMT will be accumulated in setham - EMT(:NELMNT) = 0.D0 - - READ (30) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - - NCFPAT = NCFPAST(JBLOCK) - NCMINPAT = NCMINPAST(JBLOCK) - NEVECPAT = NEVECPAST(JBLOCK) - + EMT(:NELMNT) = 0.D0 + + READ (30) (IENDC(I),I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + + NCFPAT = NCFPAST(JBLOCK) + NCMINPAT = NCMINPAST(JBLOCK) + NEVECPAT = NEVECPAST(JBLOCK) + !======================================================================= ! Skip current block if no eigenlaue is required !======================================================================= - - IF (NEVBLK(JBLOCK) == 0) THEN - DO NFILE = 31, 32 + KMAXF - READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF - IF (JBLOCKT /= JBLOCK) STOP 'matrx: jblockt .NE. jblock' - IF (NCFT /= NCF) STOP 'matrx: ncft .NE. ncf' - - READ (NFILE) LAB, NCONTR - DO WHILE(LAB/=0 .OR. NCONTR/=0) - READ (NFILE) (ITMP,ITMP,TMP,I=1,NCONTR) - READ (NFILE) LAB, NCONTR - END DO - END DO - - CALL DALLOC (IENDC, 'IENDC', 'MATRIX') - CALL DALLOC (IROW, 'IROW', 'MATRIX') - - CYCLE - - ENDIF - + + IF (NEVBLK(JBLOCK) == 0) THEN + DO NFILE = 31, 32 + KMAXF + READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF + IF (JBLOCKT /= JBLOCK) STOP 'matrx: jblockt .NE. jblock' + IF (NCFT /= NCF) STOP 'matrx: ncft .NE. ncf' + + READ (NFILE) LAB, NCONTR + DO WHILE(LAB/=0 .OR. NCONTR/=0) + READ (NFILE) (ITMP,ITMP,TMP,I=1,NCONTR) + READ (NFILE) LAB, NCONTR + END DO + END DO + + CALL DALLOC (IENDC, 'IENDC', 'MATRIX') + CALL DALLOC (IROW, 'IROW', 'MATRIX') + + CYCLE + + ENDIF + !======================================================================= ! Generate the Hamiltonian matrix - average energy is removed here !======================================================================= - - CALL SETHAM (JBLOCK, MYID, NPROCS) + + CALL SETHAM (JBLOCK, MYID, NPROCS) ! ! Determine average energy ! - EAV = 0.D0 + EAV = 0.D0 DO IR = myid + 1, ncf, nprocs - EAV = EAV + EMT(IENDC(IR)) + EAV = EAV + EMT(IENDC(IR)) END DO ! DO IR = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS ! EAV = EAV + EMT(IENDC(NPROCS*(IR-1)+MYID+1)) ! END DO - - EAV = EAV/NCF - EAVBLK(JBLOCK) = EAV - + + EAV = EAV/NCF + EAVBLK(JBLOCK) = EAV + ! Print Hamiltonian matrix and average energy ! hmout is not general !call hmout (0, 1, ncf) - - IF (MYID == 0) WRITE (*, 302) EAV - + + IF (MYID == 0) WRITE (*, 302) EAV + ! Subtract the average energy from the diagonal elements ! to reduce the condition number of the matrix -! DO I = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS +! DO I = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS ! EMT(IENDC(NPROCS*(I-1)+MYID+1)) = EMT(IENDC(NPROCS*(I-1)+MYID+1))& -! - EAV +! - EAV DO i = myid + 1, ncf, nprocs idiag = iendc(i) ! new mode: each row ends in diagonal emt(idiag) = emt(idiag) - eav - END DO - + END DO + !======================================================================= ! Compute and store eigenpairs !======================================================================= - + CALL MANEIG (dvdfirst, LDBPG(3), & - JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) - + JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + !======================================================================= ! Damp and Schmidt orthogonalise eigenvectors for OL calculations !======================================================================= - - IF (.NOT.FIRST) THEN - - DO J = 1, NEVBLK(JBLOCK) - - IOFSET = (J - 1)*NCF + NEVECPAT - JOTHER = J - + + IF (.NOT.FIRST) THEN + + DO J = 1, NEVBLK(JBLOCK) + + IOFSET = (J - 1)*NCF + NEVECPAT + JOTHER = J + ! cdamp has the original non-block feature - CDAMPJ = CDAMP(J + NCMINPAT) - IF (CDAMPJ == 0.D0) CYCLE ! So SURE ??? - - OMCDAJ = 1.D0 - CDAMPJ - + CDAMPJ = CDAMP(J + NCMINPAT) + IF (CDAMPJ == 0.D0) CYCLE ! So SURE ??? + + OMCDAJ = 1.D0 - CDAMPJ + !...Damp eigenvector and determine the new dominant component - 123 CONTINUE - AMAX = 0.D0 - DO I = 1, NCF - EVECIJ = OMCDAJ*EVEC(I+IOFSET) + CDAMPJ*CMVL(I + IOFSET) - EVEC(I+IOFSET) = EVECIJ - WA = ABS(EVECIJ) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO - + 123 CONTINUE + AMAX = 0.D0 + DO I = 1, NCF + EVECIJ = OMCDAJ*EVEC(I+IOFSET) + CDAMPJ*CMVL(I + IOFSET) + EVEC(I+IOFSET) = EVECIJ + WA = ABS(EVECIJ) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO + !...compute the normalization factor - SUM = 0.D0 - DO I = 1, NCF - SUM = SUM + EVEC(I+IOFSET)**2 - END DO - DNFAC = 1.D0/SQRT(SUM) - + SUM = 0.D0 + DO I = 1, NCF + SUM = SUM + EVEC(I+IOFSET)**2 + END DO + DNFAC = 1.D0/SQRT(SUM) + !...Renormalize and invert as necessary - IF (EVEC(IA+IOFSET) < 0.D0) DNFAC = -DNFAC - CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) - + IF (EVEC(IA+IOFSET) < 0.D0) DNFAC = -DNFAC + CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) + !...Schmidt orthogonalise - 234 CONTINUE - JOTHER = JOTHER - 1 - IF (JOTHER < 1) CYCLE - JOFSET = (JOTHER - 1)*NCF + NEVECPAT - OVRLAP = DDOT(NCF,EVEC(IOFSET+1),1,EVEC(JOFSET+1),1) - IF (OVRLAP /= 0.D0) THEN ! So SURE ??? - OMCDAJ = 1.D0 - CDAMPJ = -OVRLAP - CALL DCOPY (NCF, EVEC(JOFSET+1), 1, CMVL(IOFSET + 1), 1) - GO TO 123 - ELSE - GO TO 234 - ENDIF - END DO - ENDIF - + 234 CONTINUE + JOTHER = JOTHER - 1 + IF (JOTHER < 1) CYCLE + JOFSET = (JOTHER - 1)*NCF + NEVECPAT + OVRLAP = DDOT(NCF,EVEC(IOFSET+1),1,EVEC(JOFSET+1),1) + IF (OVRLAP /= 0.D0) THEN ! So SURE ??? + OMCDAJ = 1.D0 + CDAMPJ = -OVRLAP + CALL DCOPY (NCF, EVEC(JOFSET+1), 1, CMVL(IOFSET + 1), 1) + GO TO 123 + ELSE + GO TO 234 + ENDIF + END DO + ENDIF + ! Write out the eigenpair information: ASF symmetries, eigenvalues, ! and eigenvectors to GRASP92 mixing coefficients File - - IF (NEVBLK(JBLOCK) == 0) THEN - IATTMP = 999 - IASTMP = 999 - ELSE + + IF (NEVBLK(JBLOCK) == 0) THEN + IATTMP = 999 + IASTMP = 999 + ELSE !GGGG iattmp = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -284,35 +284,35 @@ SUBROUTINE MATRIX(dvdfirst) !PS iastmp = 1 iastmp = -1 END IF -!GG IATTMP = IATJPO(NCMINPAT + 1) -!GG IASTMP = IASPAR(NCMINPAT + 1) - ENDIF - - IF (MYID == 0) THEN - WRITE (25) JBLOCK, NCF, NEVBLK(JBLOCK), IATTMP, IASTMP - WRITE (25) (ICCMIN(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) - WRITE (25) EAV, (EVAL(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) +!GG IATTMP = IATJPO(NCMINPAT + 1) +!GG IASTMP = IASPAR(NCMINPAT + 1) + ENDIF + + IF (MYID == 0) THEN + WRITE (25) JBLOCK, NCF, NEVBLK(JBLOCK), IATTMP, IASTMP + WRITE (25) (ICCMIN(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) + WRITE (25) EAV, (EVAL(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) WRITE (25) ((EVEC(I+(J-1)*NCF+NEVECPAT),I=1,NCF),J=1,NEVBLK(JBLOCK)& - ) - ENDIF - - CALL DALLOC (EMT, 'EMT', 'MATRIX') - CALL DALLOC (IENDC, 'IENDC', 'MATRIX') - CALL DALLOC (IROW, 'IROW', 'MATRIX') - + ) + ENDIF + + CALL DALLOC (EMT, 'EMT', 'MATRIX') + CALL DALLOC (IENDC, 'IENDC', 'MATRIX') + CALL DALLOC (IROW, 'IROW', 'MATRIX') + !---------------------- - END DO + END DO !---------------------- ! ! Deallocate the temporary storage ! - IF (.NOT.FIRST) THEN - CALL DALLOC (CMVL, 'CMVL', 'MATRIX') - ELSE - FIRST = .FALSE. - ENDIF - - 302 FORMAT(' Average energy = ',1P,D18.10,' Hartrees') - - RETURN - END SUBROUTINE MATRIX + IF (.NOT.FIRST) THEN + CALL DALLOC (CMVL, 'CMVL', 'MATRIX') + ELSE + FIRST = .FALSE. + ENDIF + + 302 FORMAT(' Average energy = ',1P,D18.10,' Hartrees') + + RETURN + END SUBROUTINE MATRIX diff --git a/src/appl/rmcdhf90/matrix_I.f90 b/src/appl/rmcdhf90/matrix_I.f90 index 1f876fc6b..f9cee7e87 100644 --- a/src/appl/rmcdhf90/matrix_I.f90 +++ b/src/appl/rmcdhf90/matrix_I.f90 @@ -1,10 +1,10 @@ - MODULE matrix_I + MODULE matrix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE matrix (dvdfirst) logical, INTENT(IN) :: dvdfirst - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/maxarr.f90 b/src/appl/rmcdhf90/maxarr.f90 index 98345329a..e34fa7d56 100644 --- a/src/appl/rmcdhf90/maxarr.f90 +++ b/src/appl/rmcdhf90/maxarr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MAXARR(J) + SUBROUTINE MAXARR(J) ! * ! This subroutine finds the least self-consistent orbital * ! * @@ -9,13 +9,13 @@ SUBROUTINE MAXARR(J) ! J initialized to zero ! XHH 1997.02.14 !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE fixd_C USE orb_C USE scf_C @@ -23,23 +23,23 @@ SUBROUTINE MAXARR(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(OUT) :: J + INTEGER , INTENT(OUT) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DLRGST + INTEGER :: I + REAL(DOUBLE) :: DLRGST !----------------------------------------------- ! ! - J = 0 - DLRGST = 0.D0 - DO I = 1, NW - IF (LFIX(I)) CYCLE - IF (SCNSTY(I) <= DLRGST) CYCLE - DLRGST = SCNSTY(I) - J = I - END DO + J = 0 + DLRGST = 0.D0 + DO I = 1, NW + IF (LFIX(I)) CYCLE + IF (SCNSTY(I) <= DLRGST) CYCLE + DLRGST = SCNSTY(I) + J = I + END DO ! - RETURN - END SUBROUTINE MAXARR + RETURN + END SUBROUTINE MAXARR diff --git a/src/appl/rmcdhf90/maxarr_I.f90 b/src/appl/rmcdhf90/maxarr_I.f90 index c9c7b1d85..7e8670e8c 100644 --- a/src/appl/rmcdhf90/maxarr_I.f90 +++ b/src/appl/rmcdhf90/maxarr_I.f90 @@ -1,10 +1,10 @@ - MODULE maxarr_I + MODULE maxarr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maxarr (J) - INTEGER, INTENT(OUT) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE maxarr (J) + INTEGER, INTENT(OUT) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/mpi_s.f90 b/src/appl/rmcdhf90/mpi_s.f90 index 00d89ecb4..f3a24ec20 100644 --- a/src/appl/rmcdhf90/mpi_s.f90 +++ b/src/appl/rmcdhf90/mpi_s.f90 @@ -1,7 +1,7 @@ - MODULE mpi_s - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer + MODULE mpi_s + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER :: MYID, NPROCS - END MODULE mpi_s + END MODULE mpi_s diff --git a/src/appl/rmcdhf90/newco.f90 b/src/appl/rmcdhf90/newco.f90 index 4cfbd9ccc..bb5f6e727 100644 --- a/src/appl/rmcdhf90/newco.f90 +++ b/src/appl/rmcdhf90/newco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NEWCO(SUM) + SUBROUTINE NEWCO(SUM) ! * ! This routine computes the level weights, the generalized occupa- * ! tion numbers, and average energy for EOL calculations; this * @@ -15,14 +15,14 @@ SUBROUTINE NEWCO(SUM) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C USE def_C USE eigv_C USE orb_C @@ -37,20 +37,20 @@ SUBROUTINE NEWCO(SUM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dsubrs_I + USE dsubrs_I USE iq_I - USE csfwgt_I + USE csfwgt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(OUT) :: SUM + REAL(DOUBLE), INTENT(OUT) :: SUM !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, NB, I, NOFF, JALL, JBLOCK - REAL(DOUBLE) :: WEITJ, EE - LOGICAL :: EOL + REAL(DOUBLE) :: WEITJ, EE + LOGICAL :: EOL !----------------------------------------------- ! ! POINTER (pncfblk, ncfblk(0:*)) @@ -58,74 +58,74 @@ SUBROUTINE NEWCO(SUM) ! ! Compute weighting factors ! - SUM = 0.D0 - DO J = 1, NCMIN - WEITJ = WEIGHT(J) - IF (WEITJ == (-2.D0)) THEN - WT(J) = 1.D0 - ELSE IF (WEITJ == (-1.D0)) THEN + SUM = 0.D0 + DO J = 1, NCMIN + WEITJ = WEIGHT(J) + IF (WEITJ == (-2.D0)) THEN + WT(J) = 1.D0 + ELSE IF (WEITJ == (-1.D0)) THEN !GGGG -!GG WT(J) = IATJPO(J) +!GG WT(J) = IATJPO(J) jblock = idxblk(J) ! Block number of this state WT(J) = ABS(JPGG(jblock)) - ELSE - WT(J) = WEIGHT(J) - ENDIF - SUM = SUM + WT(J) - END DO - - WT(:NCMIN) = WT(:NCMIN)/SUM + ELSE + WT(J) = WEIGHT(J) + ENDIF + SUM = SUM + WT(J) + END DO + + WT(:NCMIN) = WT(:NCMIN)/SUM ! ! Compute generalised occupation numbers ! <----- Distributed -----> ! - EOL = .TRUE. - - DO J = 1, NW - SUM = 0.D0 - DO NB = 1, NBLOCK - DO I = MYID + 1, NCFBLK(NB), NPROCS - SUM = SUM + DSUBRS(EOL,I,I,NB)*IQ(J,I + NCFPAST(NB)) - END DO - END DO - UCF(J) = SUM - END DO + EOL = .TRUE. + + DO J = 1, NW + SUM = 0.D0 + DO NB = 1, NBLOCK + DO I = MYID + 1, NCFBLK(NB), NPROCS + SUM = SUM + DSUBRS(EOL,I,I,NB)*IQ(J,I + NCFPAST(NB)) + END DO + END DO + UCF(J) = SUM + END DO ! ! Write out level energies and weights ! - WRITE (*, 300) - SUM = 0.D0 - NOFF = 0 - DO JALL = 1, NCMIN - NB = IDXBLK(JALL) ! Block number of this state - EE = EAVBLK(NB) + EVAL(JALL) - WRITE (*, 301) ICCMIN(JALL), EE, WT(JALL) - IF (LDBPG(5)) THEN - WRITE (99, *) JALL, NB, NCFBLK(NB), NEVECPAST(NB) - WRITE (99, 302) - WRITE (99, 303) (EVEC(I + NOFF),I=1,NCFBLK(NB)) - NOFF = NOFF + NCFBLK(NB) - ENDIF - SUM = SUM + WT(JALL)*EE - END DO - - CALL CSFWGT (.TRUE.) + WRITE (*, 300) + SUM = 0.D0 + NOFF = 0 + DO JALL = 1, NCMIN + NB = IDXBLK(JALL) ! Block number of this state + EE = EAVBLK(NB) + EVAL(JALL) + WRITE (*, 301) ICCMIN(JALL), EE, WT(JALL) + IF (LDBPG(5)) THEN + WRITE (99, *) JALL, NB, NCFBLK(NB), NEVECPAST(NB) + WRITE (99, 302) + WRITE (99, 303) (EVEC(I + NOFF),I=1,NCFBLK(NB)) + NOFF = NOFF + NCFBLK(NB) + ENDIF + SUM = SUM + WT(JALL)*EE + END DO + + CALL CSFWGT (.TRUE.) ! ! Write out average energy ! - IF (NCMIN > 1) WRITE (*, 304) SUM + IF (NCMIN > 1) WRITE (*, 304) SUM ! ! Write out generalized occupation numbers ! - WRITE (*, 305) - WRITE (*, 303) (UCF(I),I=1,NW) - - 300 FORMAT(/,'Optimise on the following level(s):'/) - 301 FORMAT('Level ',1I2,4X,'Energy = ',1P,1D19.12,4X,'Weight = ',1D12.5) - 302 FORMAT(/,'Configuration mixing coefficients:') - 303 FORMAT(1X,1P,6D12.4) - 304 FORMAT(/,'Weighted average energy of these levels = ',1P,D18.10) - 305 FORMAT(/,'Generalised occupation numbers:'/) - - RETURN - END SUBROUTINE NEWCO + WRITE (*, 305) + WRITE (*, 303) (UCF(I),I=1,NW) + + 300 FORMAT(/,'Optimise on the following level(s):'/) + 301 FORMAT('Level ',1I2,4X,'Energy = ',1P,1D19.12,4X,'Weight = ',1D12.5) + 302 FORMAT(/,'Configuration mixing coefficients:') + 303 FORMAT(1X,1P,6D12.4) + 304 FORMAT(/,'Weighted average energy of these levels = ',1P,D18.10) + 305 FORMAT(/,'Generalised occupation numbers:'/) + + RETURN + END SUBROUTINE NEWCO diff --git a/src/appl/rmcdhf90/newco_I.f90 b/src/appl/rmcdhf90/newco_I.f90 index fab657dad..928841b74 100644 --- a/src/appl/rmcdhf90/newco_I.f90 +++ b/src/appl/rmcdhf90/newco_I.f90 @@ -1,11 +1,11 @@ - MODULE newco_I + MODULE newco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE newco (SUM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(OUT) :: SUM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE newco (SUM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(OUT) :: SUM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/newe.f90 b/src/appl/rmcdhf90/newe.f90 index 63c01dc04..b546e6f45 100644 --- a/src/appl/rmcdhf90/newe.f90 +++ b/src/appl/rmcdhf90/newe.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) ! * ! This subroutine implements Part 2 of Algorithm 7.1 in C Froese * ! Fischer, Comput Phys Rep, 3 (1986) 273-326. (The present code * @@ -12,116 +12,116 @@ SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) ! Written by Farid A Parpia, at Oxford Last Update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE int_C USE orb_C USE scf_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE outbnd_I + USE outbnd_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J - INTEGER , INTENT(IN) :: NPRIME - INTEGER , INTENT(IN) :: MX - INTEGER , INTENT(OUT) :: INV - REAL(DOUBLE) , INTENT(IN) :: SGN - REAL(DOUBLE) , INTENT(INOUT) :: DELEPS - LOGICAL , INTENT(OUT) :: FAIL + INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: NPRIME + INTEGER , INTENT(IN) :: MX + INTEGER , INTENT(OUT) :: INV + REAL(DOUBLE) , INTENT(IN) :: SGN + REAL(DOUBLE) , INTENT(INOUT) :: DELEPS + LOGICAL , INTENT(OUT) :: FAIL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P02 = 2.0D-02 - REAL(DOUBLE), PARAMETER :: P05 = 5.0D-02 - REAL(DOUBLE), PARAMETER :: P001 = 1.0D-03 - REAL(DOUBLE), PARAMETER :: P00001 = 1.0D-05 - REAL(DOUBLE), PARAMETER :: D2P5 = 2.5D00 + REAL(DOUBLE), PARAMETER :: P02 = 2.0D-02 + REAL(DOUBLE), PARAMETER :: P05 = 5.0D-02 + REAL(DOUBLE), PARAMETER :: P001 = 1.0D-03 + REAL(DOUBLE), PARAMETER :: P00001 = 1.0D-05 + REAL(DOUBLE), PARAMETER :: D2P5 = 2.5D00 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: EPS, ABDELE, DELEBE, DN, DNPRME, DNPN25, ETRY, DELTA + INTEGER :: I + REAL(DOUBLE) :: EPS, ABDELE, DELEBE, DN, DNPRME, DNPN25, ETRY, DELTA !----------------------------------------------- ! ! ! Determine if the iterative process has succeeded ! - IF (SGN>0.0D00 .AND. MX==0) THEN - FAIL = .FALSE. - ELSE - FAIL = .TRUE. - ENDIF + IF (SGN>0.0D00 .AND. MX==0) THEN + FAIL = .FALSE. + ELSE + FAIL = .TRUE. + ENDIF ! ! Inversion counter ! - INV = 0 + INV = 0 ! ! If unsuccessful, obtain a new estimate of the eigenvalue ! - IF (FAIL) THEN + IF (FAIL) THEN ! ! Define quantities used later ! - EPS = E(J) - ABDELE = ABS(DELEPS) - DELEBE = ABS(DELEPS/EPS) - DN = DBLE(NP(J)) - DNPRME = DBLE(NPRIME) - DNPN25 = (DNPRME/DN)**D2P5 + EPS = E(J) + ABDELE = ABS(DELEPS) + DELEBE = ABS(DELEPS/EPS) + DN = DBLE(NP(J)) + DNPRME = DBLE(NPRIME) + DNPN25 = (DNPRME/DN)**D2P5 ! IF (ABS(MX)==1 .AND. DELEBE>P02 .OR. MX==0 .AND. DELEBE>=P00001 .AND. & - ABDELE>=P001) THEN - 1 CONTINUE - ETRY = EPS + DELEPS - IF (OUTBND(ETRY) .AND. MX/=0) ETRY = EPS*DNPN25 - IF (OUTBND(ETRY)) ETRY = EPS - DELEPS - IF (OUTBND(ETRY)) THEN - DELEPS = 0.5D00*DELEPS - GO TO 1 - ENDIF - ELSE IF (MX == 0) THEN - ETRY = EPS - INV = 1 - P0 = -P0 - P(:MTP0) = -P(:MTP0) - Q(:MTP0) = -Q(:MTP0) - FAIL = .FALSE. - ELSE IF (SGN < 0.0D00) THEN - ETRY = EPS*DNPN25 - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPS) - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMIN + EPS) - ELSE IF (MX < 0) THEN - DELTA = 1.0D00 - EPS/EPSMAX - EPSMAX = EPS - IF (DELTA < P05) THEN - EMAX = EMAX*DNPN25 - ELSE - EMAX = EPS*DNPN25 - ENDIF - ETRY = EMAX - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) - ELSE IF (MX > 0) THEN - DELTA = 1.0D00 - EPSMIN/EPS - EPSMIN = EPS - IF (DELTA < P05) THEN - EMIN = EMIN*DNPN25 - ELSE - EMIN = EPS*DNPN25 - ENDIF - ETRY = EMIN - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) - ENDIF - E(J) = ETRY - ENDIF + ABDELE>=P001) THEN + 1 CONTINUE + ETRY = EPS + DELEPS + IF (OUTBND(ETRY) .AND. MX/=0) ETRY = EPS*DNPN25 + IF (OUTBND(ETRY)) ETRY = EPS - DELEPS + IF (OUTBND(ETRY)) THEN + DELEPS = 0.5D00*DELEPS + GO TO 1 + ENDIF + ELSE IF (MX == 0) THEN + ETRY = EPS + INV = 1 + P0 = -P0 + P(:MTP0) = -P(:MTP0) + Q(:MTP0) = -Q(:MTP0) + FAIL = .FALSE. + ELSE IF (SGN < 0.0D00) THEN + ETRY = EPS*DNPN25 + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPS) + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMIN + EPS) + ELSE IF (MX < 0) THEN + DELTA = 1.0D00 - EPS/EPSMAX + EPSMAX = EPS + IF (DELTA < P05) THEN + EMAX = EMAX*DNPN25 + ELSE + EMAX = EPS*DNPN25 + ENDIF + ETRY = EMAX + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) + ELSE IF (MX > 0) THEN + DELTA = 1.0D00 - EPSMIN/EPS + EPSMIN = EPS + IF (DELTA < P05) THEN + EMIN = EMIN*DNPN25 + ELSE + EMIN = EPS*DNPN25 + ENDIF + ETRY = EMIN + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) + ENDIF + E(J) = ETRY + ENDIF ! - RETURN - END SUBROUTINE NEWE + RETURN + END SUBROUTINE NEWE diff --git a/src/appl/rmcdhf90/newe_I.f90 b/src/appl/rmcdhf90/newe_I.f90 index 74086cfa0..ff75662e1 100644 --- a/src/appl/rmcdhf90/newe_I.f90 +++ b/src/appl/rmcdhf90/newe_I.f90 @@ -1,17 +1,17 @@ - MODULE newe_I + MODULE newe_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE newe (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(IN) :: SGN - INTEGER, INTENT(IN) :: NPRIME - INTEGER, INTENT(IN) :: MX - REAL(DOUBLE), INTENT(INOUT) :: DELEPS - LOGICAL, INTENT(OUT) :: FAIL - INTEGER, INTENT(OUT) :: INV - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE newe (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(IN) :: SGN + INTEGER, INTENT(IN) :: NPRIME + INTEGER, INTENT(IN) :: MX + REAL(DOUBLE), INTENT(INOUT) :: DELEPS + LOGICAL, INTENT(OUT) :: FAIL + INTEGER, INTENT(OUT) :: INV + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/orbout.f90 b/src/appl/rmcdhf90/orbout.f90 index c2fb9656e..51bb929e0 100644 --- a/src/appl/rmcdhf90/orbout.f90 +++ b/src/appl/rmcdhf90/orbout.f90 @@ -1,13 +1,13 @@ !*********************************************************************** - SUBROUTINE ORBOUT(RWFFILE2) + SUBROUTINE ORBOUT(RWFFILE2) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE orb_C USE wave_C @@ -15,23 +15,23 @@ SUBROUTINE ORBOUT(RWFFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: RWFFILE2*(*) + CHARACTER , INTENT(IN) :: RWFFILE2*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, MFJ, I + INTEGER :: J, MFJ, I !----------------------------------------------- ! OPEN(23, FILE=RWFFILE2, STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - WRITE (23) 'G92RWF' - DO J = 1, NW - MFJ = MF(J) - WRITE (23) NP(J), NAK(J), E(J), MFJ - WRITE (23) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) - WRITE (23) (R(I),I=1,MFJ) ! This is a waste of resources - END DO - CLOSE(23) - - RETURN - END SUBROUTINE ORBOUT + 'asis') + WRITE (23) 'G92RWF' + DO J = 1, NW + MFJ = MF(J) + WRITE (23) NP(J), NAK(J), E(J), MFJ + WRITE (23) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) + WRITE (23) (R(I),I=1,MFJ) ! This is a waste of resources + END DO + CLOSE(23) + + RETURN + END SUBROUTINE ORBOUT diff --git a/src/appl/rmcdhf90/orbout_I.f90 b/src/appl/rmcdhf90/orbout_I.f90 index 5e909547f..681946f89 100644 --- a/src/appl/rmcdhf90/orbout_I.f90 +++ b/src/appl/rmcdhf90/orbout_I.f90 @@ -1,10 +1,10 @@ - MODULE orbout_I + MODULE orbout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orbout (RWFFILE2) - CHARACTER (LEN = *), INTENT(IN) :: RWFFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE orbout (RWFFILE2) + CHARACTER (LEN = *), INTENT(IN) :: RWFFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/orthor.f90 b/src/appl/rmcdhf90/orthor.f90 index 352a6bbb8..c9659e1fd 100644 --- a/src/appl/rmcdhf90/orthor.f90 +++ b/src/appl/rmcdhf90/orthor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ORTHOR(J, INV) + SUBROUTINE ORTHOR(J, INV) ! ! * ! This routine Schmidt orthogonalizes orbital J to all orbitals * @@ -18,18 +18,18 @@ SUBROUTINE ORTHOR(J, INV) ! Anyway this routine was not used anywhere. !XHH 1997.02.21 !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEF_C + USE DEF_C USE GRID_C - USE OVL_C - USE ORB_C + USE OVL_C + USE ORB_C USE ORBA_C USE INVT_C USE SCF_C @@ -39,37 +39,37 @@ SUBROUTINE ORTHOR(J, INV) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I -! USE count_I + USE rint_I +! USE count_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER , INTENT(INOUT) :: INV + INTEGER :: J + INTEGER , INTENT(INOUT) :: INV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KRAW, K, MTP, I, NNCFF, JGG - REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR, SGN - LOGICAL :: CHECK, CHANGED + REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR, SGN + LOGICAL :: CHECK, CHANGED !----------------------------------------------- ! !XHH Added common /orba/ and /iounit/ - + ! !ww EPS = ACCY*0.1D 00 - EPS = ACCY*0.01D00 + EPS = ACCY*0.01D00 ! - CHECK = .NOT.NOINVT(J) + CHECK = .NOT.NOINVT(J) ! !XHH ! Bug fixed. Here J is actually IORDER(J_raw), thus K should be ! treated the same way. - CHANGED = .FALSE. + CHANGED = .FALSE. ! DO 4 K = 1,NW - DO KRAW = 1, NW - K = IORDER(KRAW) + DO KRAW = 1, NW + K = IORDER(KRAW) ! write(istde,*) '***',kraw,k,np(k),nh(k),scnsty(k),'***' ! !XHH orbitals with higher self-consistency are considered @@ -80,63 +80,63 @@ SUBROUTINE ORTHOR(J, INV) ! IF ( (K .NE. J) .AND. ! : (NAK(K) .EQ. NAK(J)) ) THEN !XHH orbitals before the current and unchanged ones are considered - IF (.NOT.(NAK(K)==NAK(J) .AND. (K= SCNSTY(KI)/E(KI)**2) CYCLE - + + DO I = KFIXED + 1, KFIXED + KNON + KI = KINDX(I) + DO J = I + 1, KFIXED + KNON + KJ = KINDX(J) + IF (SCNSTY(KJ)/E(KJ)**2 >= SCNSTY(KI)/E(KI)**2) CYCLE + ! No need to do shifting, exchanging is fine - KINDX(J) = KI - KI = KJ - END DO - KINDX(I) = KI - END DO - + KINDX(J) = KI + KI = KJ + END DO + KINDX(I) = KI + END DO + ! correlation orbitals, using criteria scnsty - - DO I = KFIXED + KNON + 1, KTOTAL - KI = KINDX(I) - DO J = I + 1, KTOTAL - KJ = KINDX(J) - IF (SCNSTY(KJ) >= SCNSTY(KI)) CYCLE - + + DO I = KFIXED + KNON + 1, KTOTAL + KI = KINDX(I) + DO J = I + 1, KTOTAL + KJ = KINDX(J) + IF (SCNSTY(KJ) >= SCNSTY(KI)) CYCLE + ! No need to do shifting, exchanging is fine - KINDX(J) = KI - KI = KJ - END DO - KINDX(I) = KI - END DO - - ENDIF - + KINDX(J) = KI + KI = KJ + END DO + KINDX(I) = KI + END DO + + ENDIF + ! Finished sorting. ! Schmidt orthogonalize all orbitals of the same kappa ! The fixed orbitals are not changed - - DO LRAW = KFIXED + 1, KTOTAL - L = KINDX(LRAW) - - NAKL = NAK(L) - - MTP0 = MF(L) - - DO KRAW = 1, LRAW - 1 - K = KINDX(KRAW) - OVRLAP = RINT(L,K,0) - + + DO LRAW = KFIXED + 1, KTOTAL + L = KINDX(LRAW) + + NAKL = NAK(L) + + MTP0 = MF(L) + + DO KRAW = 1, LRAW - 1 + K = KINDX(KRAW) + OVRLAP = RINT(L,K,0) + ! Schmidt orthogonalise - - PZ(L) = PZ(L) - OVRLAP*PZ(K) - MTP = MAX(MF(L),MF(K)) - MTP0 = MAX(MTP0,MF(K)) - - PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) - QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) - END DO - + + PZ(L) = PZ(L) - OVRLAP*PZ(K) + MTP = MAX(MF(L),MF(K)) + MTP0 = MAX(MTP0,MF(K)) + + PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) + QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) + END DO + ! Normalise - - MTP = MTP0 - - MF(L) = MTP - DNORM = RINT(L,L,0) - FACTOR = 1.D0/SQRT(DNORM) - - IF (PZ(L) < 0.D0) FACTOR = -FACTOR - - PZ(L) = FACTOR*PZ(L) - PF(2:MTP,L) = FACTOR*PF(2:MTP,L) - QF(2:MTP,L) = FACTOR*QF(2:MTP,L) - + + MTP = MTP0 + + MF(L) = MTP + DNORM = RINT(L,L,0) + FACTOR = 1.D0/SQRT(DNORM) + + IF (PZ(L) < 0.D0) FACTOR = -FACTOR + + PZ(L) = FACTOR*PZ(L) + PF(2:MTP,L) = FACTOR*PF(2:MTP,L) + QF(2:MTP,L) = FACTOR*QF(2:MTP,L) + ! Find new MF(L) - - MTP = MTP + 1 - 20 CONTINUE - MTP = MTP - 1 - IF (ABS(PF(MTP,L)) < EPS) THEN - PF(MTP,L) = 0.D0 - QF(MTP,L) = 0.D0 - GO TO 20 - ELSE - MF(L) = MTP - ENDIF - - END DO - - RETURN - END SUBROUTINE ORTHY + + MTP = MTP + 1 + 20 CONTINUE + MTP = MTP - 1 + IF (ABS(PF(MTP,L)) < EPS) THEN + PF(MTP,L) = 0.D0 + QF(MTP,L) = 0.D0 + GO TO 20 + ELSE + MF(L) = MTP + ENDIF + + END DO + + RETURN + END SUBROUTINE ORTHY diff --git a/src/appl/rmcdhf90/orthy_I.f90 b/src/appl/rmcdhf90/orthy_I.f90 index e7dab74ad..20b005ea5 100644 --- a/src/appl/rmcdhf90/orthy_I.f90 +++ b/src/appl/rmcdhf90/orthy_I.f90 @@ -1,12 +1,12 @@ - MODULE orthy_I + MODULE orthy_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:57:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:57:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orthy (NW, JP, LSORT) - INTEGER, INTENT(IN) :: NW - INTEGER, INTENT(IN) :: JP - LOGICAL, INTENT(IN) :: LSORT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE orthy (NW, JP, LSORT) + INTEGER, INTENT(IN) :: NW + INTEGER, INTENT(IN) :: JP + LOGICAL, INTENT(IN) :: LSORT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/out.f90 b/src/appl/rmcdhf90/out.f90 index 6577bf7eb..afe8e7a90 100644 --- a/src/appl/rmcdhf90/out.f90 +++ b/src/appl/rmcdhf90/out.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE OUT(J, JP, P, Q) + SUBROUTINE OUT(J, JP, P, Q) ! * ! This subroutine carries out the step-by-step outward integration * ! of a pair of inhomogeneous Dirac radial equations. * @@ -17,13 +17,13 @@ SUBROUTINE OUT(J, JP, P, Q) ! Written by Farid A Parpia, at Oxford Last updated: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C, ONLY: h, rpor USE int_C, ONLY: TF ,TG ,XU, XV @@ -32,58 +32,58 @@ SUBROUTINE OUT(J, JP, P, Q) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J - INTEGER , INTENT(IN) :: JP - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: JP + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I REAL(DOUBLE) :: DKHB2, DKHB2F, CPI, CMI, PI, QI, TFI, TGI, CPIM1, CMIM1, & - PIM1, QIM1, TFIM1, TGIM1, UCIM1, UDIM1, UEI + PIM1, QIM1, TFIM1, TGIM1, UCIM1, UDIM1, UEI !----------------------------------------------- ! ! One global initialization ! - DKHB2 = 0.5D00*H*DBLE(NAK(J)) + DKHB2 = 0.5D00*H*DBLE(NAK(J)) ! ! Tabulate P(r) and Q(r) by step-by-step integration ! ! Initializations: set quantities for I = 3 ! - I = 3 - DKHB2F = DKHB2*RPOR(I) - CPI = 1.0D00 + DKHB2F - CMI = 1.0D00 - DKHB2F - PI = P(I) - QI = Q(I) - TFI = TF(I) - TGI = TG(I) + I = 3 + DKHB2F = DKHB2*RPOR(I) + CPI = 1.0D00 + DKHB2F + CMI = 1.0D00 - DKHB2F + PI = P(I) + QI = Q(I) + TFI = TF(I) + TGI = TG(I) ! ! March out to from I = 4 to I = JP ! !XHH Use doo-loop - DO I = 4, JP - CPIM1 = CPI - CMIM1 = CMI - DKHB2F = DKHB2*RPOR(I) - CPI = 1.0D00 + DKHB2F - CMI = 1.0D00 - DKHB2F - PIM1 = PI - QIM1 = QI - TFIM1 = TFI - TGIM1 = TGI - TFI = TF(I) - TGI = TG(I) - UCIM1 = CMIM1*PIM1 - TFIM1*QIM1 + XU(I-1) - UDIM1 = CPIM1*QIM1 - TGIM1*PIM1 + XV(I-1) - UEI = CPI*CMI - TFI*TGI - PI = (CMI*UCIM1 - TFI*UDIM1)/UEI - QI = (CPI*UDIM1 - TGI*UCIM1)/UEI - P(I) = PI - Q(I) = QI - END DO + DO I = 4, JP + CPIM1 = CPI + CMIM1 = CMI + DKHB2F = DKHB2*RPOR(I) + CPI = 1.0D00 + DKHB2F + CMI = 1.0D00 - DKHB2F + PIM1 = PI + QIM1 = QI + TFIM1 = TFI + TGIM1 = TGI + TFI = TF(I) + TGI = TG(I) + UCIM1 = CMIM1*PIM1 - TFIM1*QIM1 + XU(I-1) + UDIM1 = CPIM1*QIM1 - TGIM1*PIM1 + XV(I-1) + UEI = CPI*CMI - TFI*TGI + PI = (CMI*UCIM1 - TFI*UDIM1)/UEI + QI = (CPI*UDIM1 - TGI*UCIM1)/UEI + P(I) = PI + Q(I) = QI + END DO ! - RETURN - END SUBROUTINE OUT + RETURN + END SUBROUTINE OUT diff --git a/src/appl/rmcdhf90/out_I.f90 b/src/appl/rmcdhf90/out_I.f90 index 9a80a076e..a3fc2259f 100644 --- a/src/appl/rmcdhf90/out_I.f90 +++ b/src/appl/rmcdhf90/out_I.f90 @@ -1,15 +1,15 @@ - MODULE out_I + MODULE out_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE out (J, JP, P, Q) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE out (J, JP, P, Q) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: JP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: JP + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/outbnd.f90 b/src/appl/rmcdhf90/outbnd.f90 index 4a185ed75..0d775d858 100644 --- a/src/appl/rmcdhf90/outbnd.f90 +++ b/src/appl/rmcdhf90/outbnd.f90 @@ -1,7 +1,7 @@ - + !*********************************************************************** ! * - LOGICAL FUNCTION OUTBND (ETRY) + LOGICAL FUNCTION OUTBND (ETRY) ! * ! This subprogram determines whether the trial eigenvalue etry is * ! within the bounds (EPSMIN,EPSMAX) * @@ -9,29 +9,29 @@ LOGICAL FUNCTION OUTBND (ETRY) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE SCF_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: ETRY + REAL(DOUBLE) , INTENT(IN) :: ETRY !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! - IF (ETRY>EPSMIN .AND. ETRYEPSMIN .AND. ETRY 75) THEN - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - ENDIF - IF (IEND > 0) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - ENDIF - IBEG = IEND + 1 - CALL CONVRT (NP(LOC), CNUM, LENTH) - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IF (NAK(LOC) < 0) THEN - LENTH = 1 - ELSE - LENTH = 2 - ENDIF - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = NH(LOC)(1:LENTH) + IF (IEND > 75) THEN + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + ENDIF + IF (IEND > 0) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + ENDIF + IBEG = IEND + 1 + CALL CONVRT (NP(LOC), CNUM, LENTH) + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IF (NAK(LOC) < 0) THEN + LENTH = 1 + ELSE + LENTH = 2 + ENDIF + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = NH(LOC)(1:LENTH) ! ENDIF - END DO - IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) + END DO + IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) ! - RETURN - END SUBROUTINE PRTRSL + RETURN + END SUBROUTINE PRTRSL diff --git a/src/appl/rmcdhf90/prtrsl_I.f90 b/src/appl/rmcdhf90/prtrsl_I.f90 index 8af1a6406..ae75c4208 100644 --- a/src/appl/rmcdhf90/prtrsl_I.f90 +++ b/src/appl/rmcdhf90/prtrsl_I.f90 @@ -1,9 +1,9 @@ - MODULE prtrsl_I + MODULE prtrsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prtrsl - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE prtrsl + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/prwf.f90 b/src/appl/rmcdhf90/prwf.f90 index 61f971dd3..8684ae5aa 100644 --- a/src/appl/rmcdhf90/prwf.f90 +++ b/src/appl/rmcdhf90/prwf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRWF(J) + SUBROUTINE PRWF(J) ! * ! Makes a (debug) printout of wave functions. There are two modes: * ! * @@ -14,11 +14,11 @@ SUBROUTINE PRWF(J) ! Written by Farid A Parpia, at Oxford Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP @@ -30,79 +30,79 @@ SUBROUTINE PRWF(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- -! USE draw_I +! USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NB2, NROWS, II, II1, II2, K, MFK, JGG - REAL(DOUBLE) :: CBZ + REAL(DOUBLE) :: CBZ !----------------------------------------------- ! ! - CBZ = C/Z + CBZ = C/Z ! - IF (J > 0) THEN + IF (J > 0) THEN ! ! Mode (1) ! - WRITE (99, 300) NP(J), NH(J) - NB2 = MTP0/2 - IF (2*NB2 == MTP0) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= MTP0) THEN - WRITE (99, 301) R(II1), P(II1), Q(II1), R(II2), P(II2), Q(II2) - ELSE IF (II1 <= MTP0) THEN - WRITE (99, 301) R(II1), P(II1), Q(II1) - ENDIF - END DO - CALL DRAW (P, 1.0D00, Q, CBZ, MTP0) + WRITE (99, 300) NP(J), NH(J) + NB2 = MTP0/2 + IF (2*NB2 == MTP0) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= MTP0) THEN + WRITE (99, 301) R(II1), P(II1), Q(II1), R(II2), P(II2), Q(II2) + ELSE IF (II1 <= MTP0) THEN + WRITE (99, 301) R(II1), P(II1), Q(II1) + ENDIF + END DO + CALL DRAW (P, 1.0D00, Q, CBZ, MTP0) ! - ELSE + ELSE ! ! Mode (2) ! - DO K = 1, NW - WRITE (99, 300) NP(K), NH(K) - MFK = MF(K) - NB2 = MFK/2 - IF (2*NB2 == MFK) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= MFK) THEN + DO K = 1, NW + WRITE (99, 300) NP(K), NH(K) + MFK = MF(K) + NB2 = MFK/2 + IF (2*NB2 == MFK) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= MFK) THEN WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K), R(II2), PF(II2,& - K), QF(II2,K) - ELSE IF (II1 <= MFK) THEN - WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K) - ENDIF - END DO - CALL DRAW (PF(:NNNP,K), 1.0D00, QF(:NNNP,K), CBZ, MF(K)) + K), QF(II2,K) + ELSE IF (II1 <= MFK) THEN + WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K) + ENDIF + END DO + CALL DRAW (PF(:NNNP,K), 1.0D00, QF(:NNNP,K), CBZ, MF(K)) ! - END DO + END DO ! - ENDIF + ENDIF ! - RETURN + RETURN ! 300 FORMAT('1',1I2,1A2,' orbital:'/,2(& ' --------- r --------- ------- P (r) -------',& - ' ------- Q (r) -------')) - 301 FORMAT(1P,6(1X,1D21.14)) - RETURN + ' ------- Q (r) -------')) + 301 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE PRWF + END SUBROUTINE PRWF diff --git a/src/appl/rmcdhf90/prwf_I.f90 b/src/appl/rmcdhf90/prwf_I.f90 index 61a656560..2a9801a08 100644 --- a/src/appl/rmcdhf90/prwf_I.f90 +++ b/src/appl/rmcdhf90/prwf_I.f90 @@ -1,10 +1,10 @@ - MODULE prwf_I + MODULE prwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prwf (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE prwf (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/rscfvu.f90 b/src/appl/rmcdhf90/rscfvu.f90 index 677810557..2a00b3a31 100644 --- a/src/appl/rmcdhf90/rscfvu.f90 +++ b/src/appl/rmcdhf90/rscfvu.f90 @@ -23,7 +23,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM RSCFVU + PROGRAM RSCFVU ! * ! Entry routine for RSCFVU. Controls the entire computation. * ! * @@ -39,33 +39,33 @@ PROGRAM RSCFVU ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:57:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:57:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE default_C USE core_C - USE iounit_C + USE iounit_C USE mpi_s !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE starttime_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setmcp_I - USE setcsl_I - USE getscd_I - USE strsum_I - USE setmix_I - USE factt_I - USE scf_I - USE stoptime_I + USE getyn_I + USE starttime_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setmcp_I + USE setcsl_I + USE getscd_I + USE strsum_I + USE setmix_I + USE factt_I + USE scf_I + USE stoptime_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s @@ -74,16 +74,16 @@ PROGRAM RSCFVU !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCORE1, NCOUNT1 - LOGICAL :: EOL, YES - CHARACTER, DIMENSION(NBLK0) :: IDBLK*8 + INTEGER :: NCORE1, NCOUNT1 + LOGICAL :: EOL, YES + CHARACTER, DIMENSION(NBLK0) :: IDBLK*8 !----------------------------------------------- ! ! ! Things for timing !----------------------------------------------------------------------- - MYID = 0 - NPROCS = 1 + MYID = 0 + NPROCS = 1 write(*,*) write(*,*) 'RMCDHF' @@ -95,25 +95,25 @@ PROGRAM RSCFVU 'Outputfiles: rwfn.out, rmix.out, rmcdhf.sum, rmcdhf.log' write(*,*) - CALL STARTTIME (NCOUNT1, 'RMCDHF') + CALL STARTTIME (NCOUNT1, 'RMCDHF') OPEN(UNIT=734,FILE='rmcdhf.log',STATUS='UNKNOWN') - + !======================================================================= ! Get NDEF !======================================================================= - - IF (MYID == 0) THEN - WRITE (ISTDE, '(A)', ADVANCE='NO') 'Default settings? (y/n) ' - YES = GETYN() - IF (YES) THEN - NDEF = 0 + + IF (MYID == 0) THEN + WRITE (ISTDE, '(A)', ADVANCE='NO') 'Default settings? (y/n) ' + YES = GETYN() + IF (YES) THEN + NDEF = 0 WRITE(734,'(A)') 'y ! Default settings' - ELSE - NDEF = 1 - ENDIF - ENDIF - + ELSE + NDEF = 1 + ENDIF + ENDIF + !======================================================================= ! ! Checks and settings... Mostly done in backyard. @@ -128,44 +128,44 @@ PROGRAM RSCFVU ! SETMIX - mixing coefficients file setup ! FACTT - table of logarithms of factorials setup !======================================================================= - - CALL SETDBG ('rscf92.dbg') - CALL SETMC - CALL SETCON - - CALL SETSUM ('rmcdhf.sum') - - CALL SETMCP (NCORE, NBLK0, IDBLK, 'mcp') - CALL SETCSL ('rcsf.inp', NCORE1, IDBLK) - IF (NCORE /= NCORE1) STOP 'rscfvu: ncore' - + + CALL SETDBG ('rscf92.dbg') + CALL SETMC + CALL SETCON + + CALL SETSUM ('rmcdhf.sum') + + CALL SETMCP (NCORE, NBLK0, IDBLK, 'mcp') + CALL SETCSL ('rcsf.inp', NCORE1, IDBLK) + IF (NCORE /= NCORE1) STOP 'rscfvu: ncore' + !======================================================================= ! Gather all remaining information and perform some setup. This ! part (routine) asks for user-inputs. !======================================================================= - - CALL GETSCD (EOL, IDBLK, 'isodata', 'rwfn.inp') - - IF (MYID == 0) THEN - CALL STRSUM - IF (EOL) CALL SETMIX ('rmix.out') - ENDIF - - CALL FACTT - + + CALL GETSCD (EOL, IDBLK, 'isodata', 'rwfn.inp') + + IF (MYID == 0) THEN + CALL STRSUM + IF (EOL) CALL SETMIX ('rmix.out') + ENDIF + + CALL FACTT + !======================================================================= ! Proceed with the SCF calculation close all files except ! the .sum file !======================================================================= - - CALL SCF (EOL, 'rwfn.out') + + CALL SCF (EOL, 'rwfn.out') CLOSE (734) - + !======================================================================= ! Execution finished; Statistics output !======================================================================= - - CALL STOPTIME (NCOUNT1, 'RMCDHF') - - STOP - END PROGRAM RSCFVU + + CALL STOPTIME (NCOUNT1, 'RMCDHF') + + STOP + END PROGRAM RSCFVU diff --git a/src/appl/rmcdhf90/scf.f90 b/src/appl/rmcdhf90/scf.f90 index aaa7d66cb..9046a71fc 100644 --- a/src/appl/rmcdhf90/scf.f90 +++ b/src/appl/rmcdhf90/scf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SCF(EOL, RWFFILE2) + SUBROUTINE SCF(EOL, RWFFILE2) ! * ! This subroutine performs the SCF iterations. The procedure is * ! essentially algorithm 5.1 of C Froese Fischer, Comput Phys Rep 3 * @@ -16,13 +16,13 @@ SUBROUTINE SCF(EOL, RWFFILE2) ! It was deleted the arrays: JQSA(3*NNNW*NCF), * ! JCUPA(NNNW*NCF) * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE blkidx_C USE default_C @@ -33,26 +33,26 @@ SUBROUTINE SCF(EOL, RWFFILE2) USE hblock_C USE iounit_C USE lagr_C - USE MCPA_C + USE MCPA_C USE mpi_s USE pos_c USE peav_C - USE ORB_C + USE ORB_C USE orba_C USE SCF_C USE ORTHCT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE matrix_I - USE newco_I - USE setlag_I - USE improv_I - USE maxarr_I - USE prwf_I - USE orthsc_I - USE orbout_I - USE endsum_I + USE matrix_I + USE newco_I + USE setlag_I + USE improv_I + USE maxarr_I + USE prwf_I + USE orthsc_I + USE orbout_I + USE endsum_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -60,161 +60,161 @@ SUBROUTINE SCF(EOL, RWFFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL :: EOL - CHARACTER :: RWFFILE2*(*) + LOGICAL :: EOL + CHARACTER :: RWFFILE2*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, NIT, JSEQ, KOUNT, K - REAL(DOUBLE) :: WTAEV, WTAEV0, DAMPMX + INTEGER :: J, I, NIT, JSEQ, KOUNT, K + REAL(DOUBLE) :: WTAEV, WTAEV0, DAMPMX LOGICAL :: CONVG, LSORT, dvdfirst !----------------------------------------------- - NCFTOT = NCF + NCFTOT = NCF !IF (myid .EQ. 0) PRINT *, '===SCF===' - + !======================================================================= ! Determine Orthonomalization order --- lsort !======================================================================= - - IF (NDEF == 0) THEN - LSORT = .FALSE. - ELSE - 123 CONTINUE - WRITE (ISTDE, *) 'Orthonomalization order? ' - WRITE (ISTDE, *) ' 1 -- Update order' - WRITE (ISTDE, *) ' 2 -- Self consistency connected' - READ (ISTDI, *) J - IF (J == 1) THEN - LSORT = .FALSE. - ELSE IF (J == 2) THEN - LSORT = .TRUE. - ELSE - WRITE (ISTDE, *) 'Input is wrong, redo...' - GO TO 123 - ENDIF - ENDIF - + + IF (NDEF == 0) THEN + LSORT = .FALSE. + ELSE + 123 CONTINUE + WRITE (ISTDE, *) 'Orthonomalization order? ' + WRITE (ISTDE, *) ' 1 -- Update order' + WRITE (ISTDE, *) ' 2 -- Self consistency connected' + READ (ISTDI, *) J + IF (J == 1) THEN + LSORT = .FALSE. + ELSE IF (J == 2) THEN + LSORT = .TRUE. + ELSE + WRITE (ISTDE, *) 'Input is wrong, redo...' + GO TO 123 + ENDIF + ENDIF + !======================================================================= ! Deallocate storage that will no longer be used !======================================================================= - -!GG CALL DALLOC (JQSA, 'JQSA', 'SCF') - + +!GG CALL DALLOC (JQSA, 'JQSA', 'SCF') + !======================================================================= ! Allocate and fill in auxiliary arrays !======================================================================= - - CALL ALLOC (NCFPAST, NBLOCK, 'NCFPAST', 'SCF') - CALL ALLOC (NCMINPAST, NBLOCK, 'NCMINPAST', 'SCF') - CALL ALLOC (NEVECPAST, NBLOCK, 'NEVECPAST', 'SCF') - CALL ALLOC (EAVBLK, NBLOCK, 'EAVBLK', 'SCF') - - NCFPAST(1) = 0 - NCMINPAST(1) = 0 - NEVECPAST(1) = 0 - DO I = 2, NBLOCK - NCFPAST(I) = NCFPAST(I-1) + NCFBLK(I - 1) - NCMINPAST(I) = NCMINPAST(I-1) + NEVBLK(I - 1) - NEVECPAST(I) = NEVECPAST(I-1) + NEVBLK(I - 1)*NCFBLK(I - 1) - END DO - + + CALL ALLOC (NCFPAST, NBLOCK, 'NCFPAST', 'SCF') + CALL ALLOC (NCMINPAST, NBLOCK, 'NCMINPAST', 'SCF') + CALL ALLOC (NEVECPAST, NBLOCK, 'NEVECPAST', 'SCF') + CALL ALLOC (EAVBLK, NBLOCK, 'EAVBLK', 'SCF') + + NCFPAST(1) = 0 + NCMINPAST(1) = 0 + NEVECPAST(1) = 0 + DO I = 2, NBLOCK + NCFPAST(I) = NCFPAST(I-1) + NCFBLK(I - 1) + NCMINPAST(I) = NCMINPAST(I-1) + NEVBLK(I - 1) + NEVECPAST(I) = NEVECPAST(I-1) + NEVBLK(I - 1)*NCFBLK(I - 1) + END DO + !*** Size of the eigenvector array for all blocks - NVECSIZ = NEVECPAST(NBLOCK) + NEVBLK(NBLOCK)*NCFBLK(NBLOCK) - - IF (EOL) THEN - CALL ALLOC (EVAL, NCMIN, 'EVAL', 'SCF') - CALL ALLOC (EVEC, NVECSIZ, 'EVEC', 'SCF') -!GG CALL ALLOC (IATJPO, NCMIN, 'IATJPO', 'SCF') -!GG CALL ALLOC (IASPAR, NCMIN, 'IASPAR', 'SCF') - ENDIF - + NVECSIZ = NEVECPAST(NBLOCK) + NEVBLK(NBLOCK)*NCFBLK(NBLOCK) + + IF (EOL) THEN + CALL ALLOC (EVAL, NCMIN, 'EVAL', 'SCF') + CALL ALLOC (EVEC, NVECSIZ, 'EVEC', 'SCF') +!GG CALL ALLOC (IATJPO, NCMIN, 'IATJPO', 'SCF') +!GG CALL ALLOC (IASPAR, NCMIN, 'IASPAR', 'SCF') + ENDIF + !======================================================================= ! !======================================================================= - NDDIM = 0 - NXDIM = 0 - NYDIM = 0 - + NDDIM = 0 + NXDIM = 0 + NYDIM = 0 + ! This call should only be made AFTER the call to newco ! CALL setlag (EOL) - + ! For (E)OL calculations, determine the level energies and ! mixing coefficients !CFF .. set the logical variable dvdfirst - dvdfirst = .true. - IF (EOL) THEN + dvdfirst = .true. + IF (EOL) THEN CALL MATRIX (dvdfirst) - CALL NEWCO (WTAEV) - ENDIF - WTAEV0 = 0.0 + CALL NEWCO (WTAEV) + ENDIF + WTAEV0 = 0.0 dvdfirst = .false. - DO NIT = 1, NSCF - IF (MYID == 0) WRITE (*, 301) NIT - + DO NIT = 1, NSCF + IF (MYID == 0) WRITE (*, 301) NIT + ! For all pairs constrained through a Lagrange multiplier, compute ! the Lagrange multiplier - - CALL SETLAG (EOL) - + + CALL SETLAG (EOL) + ! Improve all orbitals in turn - - DAMPMX = 0.0 - IF (MYID == 0) WRITE (*, 302) - DO J = 1, NW - JSEQ = IORDER(J) - IF (LFIX(JSEQ)) CYCLE - CALL IMPROV (EOL, JSEQ, LSORT, DAMPMX) - END DO + + DAMPMX = 0.0 + IF (MYID == 0) WRITE (*, 302) + DO J = 1, NW + JSEQ = IORDER(J) + IF (LFIX(JSEQ)) CYCLE + CALL IMPROV (EOL, JSEQ, LSORT, DAMPMX) + END DO ! ! For KOUNT = 1 to NSIC: find the least self-consistent orbital; ! improve it ! ! write(istde,*) 'nsic=',nsic - DO KOUNT = 1, NSIC - CALL MAXARR (K) - IF (K == 0) THEN - CONVG = .TRUE. - GO TO 3 - ELSE - IF (SCNSTY(K) <= ACCY) THEN - CONVG = .TRUE. - GO TO 3 - ENDIF - ENDIF - CALL IMPROV (EOL, K, LSORT, DAMPMX) - END DO - - CALL MAXARR (K) - - IF (K == 0) THEN - CONVG = .TRUE. - ELSE - IF (SCNSTY(K) <= ACCY) THEN - CONVG = .TRUE. - ELSE - CONVG = .FALSE. - ENDIF - ENDIF - - 3 CONTINUE - IF (LDBPR(24) .AND. MYID==0) CALL PRWF (0) - + DO KOUNT = 1, NSIC + CALL MAXARR (K) + IF (K == 0) THEN + CONVG = .TRUE. + GO TO 3 + ELSE + IF (SCNSTY(K) <= ACCY) THEN + CONVG = .TRUE. + GO TO 3 + ENDIF + ENDIF + CALL IMPROV (EOL, K, LSORT, DAMPMX) + END DO + + CALL MAXARR (K) + + IF (K == 0) THEN + CONVG = .TRUE. + ELSE + IF (SCNSTY(K) <= ACCY) THEN + CONVG = .TRUE. + ELSE + CONVG = .FALSE. + ENDIF + ENDIF + + 3 CONTINUE + IF (LDBPR(24) .AND. MYID==0) CALL PRWF (0) + ! Perform Gram-Schmidt process ! For OL calculation, orthst is true and orbitals are orthonormalized ! in subroutine improv. For AL calculation, orthst is false. - IF (.NOT.ORTHST) CALL ORTHSC - + IF (.NOT.ORTHST) CALL ORTHSC + ! Write the subshell radial wavefunctions to the .rwf file - - IF (MYID == 0) CALL ORBOUT (RWFFILE2) - - IF (EOL) THEN + + IF (MYID == 0) CALL ORBOUT (RWFFILE2) + + IF (EOL) THEN CALL MATRIX(dvdfirst) - CALL NEWCO (WTAEV) - ENDIF + CALL NEWCO (WTAEV) + ENDIF ! Make this a relative convergence test ! IF(ABS(WTAEV-WTAEV0).LT.1.0D-9.and. ! & DAMPMX.LT.1.0D-4) CONVG=.true. @@ -223,76 +223,76 @@ SUBROUTINE SCF(EOL, RWFFILE2) !cjb unified convergence criteria in RMCDHF and RMCDHF_MPI !cjb IF(DABS(WTAEV-WTAEV0).LT.1.0D-8.and. & !cjb DAMPMX.LT.1.0D-2) CONVG=.true. - IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE. - WTAEV0 = WTAEV - IF (.NOT.CONVG) CYCLE - IF (LDBPR(25) .AND. .NOT.LDBPR(24) .AND. MYID==0) CALL PRWF (0) + IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE. + WTAEV0 = WTAEV + IF (.NOT.CONVG) CYCLE + IF (LDBPR(25) .AND. .NOT.LDBPR(24) .AND. MYID==0) CALL PRWF (0) !IF (EOL) CALL matrix (dvdfirst) - GO TO 5 - - END DO - - IF (MYID == 0) WRITE (ISTDE, *) ' Maximum iterations in SCF Exceeded.' - - 5 CONTINUE - DO I = 31, 32 + KMAXF - CLOSE(I) ! The MCP coefficient files - END DO - - IF (MYID == 0) THEN + GO TO 5 + + END DO + + IF (MYID == 0) WRITE (ISTDE, *) ' Maximum iterations in SCF Exceeded.' + + 5 CONTINUE + DO I = 31, 32 + KMAXF + CLOSE(I) ! The MCP coefficient files + END DO + + IF (MYID == 0) THEN !CLOSE (23) ! The .rwf file - CLOSE(25) ! The .mix file + CLOSE(25) ! The .mix file ! ! Complete the summary - moved from rscf92 for easier alloc/dalloc ! - CALL ENDSUM - ENDIF + CALL ENDSUM + ENDIF ! ! Deallocate storage ! - CALL DALLOC (WT, 'WT', 'SCF') !Either getold or getald - - IF (NEC > 0) THEN - CALL DALLOC (IECC, 'IECC', 'SCF') - CALL DALLOC (ECV, 'ECV', 'SCF') -!GG CALL DALLOC (IQAR, 'IQAR', 'SCF') - CALL DALLOC (IQA, 'IQA', 'SCF') - ENDIF - - IF (NDDIM > 0) THEN - CALL DALLOC (DA, 'DA', 'SCF') - CALL DALLOC (NDA, 'NDA', 'SCF') - ENDIF - - IF (NXDIM > 0) THEN - CALL DALLOC (XA, 'XA', 'SCF') - CALL DALLOC (NXA, 'NXA', 'SCF') - ENDIF - - IF (NYDIM > 0) THEN - CALL DALLOC (YA, 'YA', 'SCF') - CALL DALLOC (NYA, 'NYA', 'SCF') - ENDIF - - IF (EOL) THEN - CALL DALLOC (EVAL, 'EVAL', 'SCF') - CALL DALLOC (EVEC, 'EvEC', 'SCF') -!GG CALL DALLOC (IATJPO, 'IATJPO', 'SCF') -!GG CALL DALLOC (IASPAR, 'IASPAR', 'SCF') - CALL DALLOC (NCMAXBLK, 'NCMAXBLK', 'SCF') ! getold.f - CALL DALLOC (EAVBLK, 'EAVBLK', 'SCF') ! getold.f - CALL DALLOC (IDXBLK, 'IDXBLK', 'SCF') ! Allocated in getold.f - CALL DALLOC (ICCMIN, 'ICCMIN', 'SCF') ! Allocated in items.f<-getold.f - ENDIF + CALL DALLOC (WT, 'WT', 'SCF') !Either getold or getald + + IF (NEC > 0) THEN + CALL DALLOC (IECC, 'IECC', 'SCF') + CALL DALLOC (ECV, 'ECV', 'SCF') +!GG CALL DALLOC (IQAR, 'IQAR', 'SCF') + CALL DALLOC (IQA, 'IQA', 'SCF') + ENDIF + + IF (NDDIM > 0) THEN + CALL DALLOC (DA, 'DA', 'SCF') + CALL DALLOC (NDA, 'NDA', 'SCF') + ENDIF + + IF (NXDIM > 0) THEN + CALL DALLOC (XA, 'XA', 'SCF') + CALL DALLOC (NXA, 'NXA', 'SCF') + ENDIF + + IF (NYDIM > 0) THEN + CALL DALLOC (YA, 'YA', 'SCF') + CALL DALLOC (NYA, 'NYA', 'SCF') + ENDIF + + IF (EOL) THEN + CALL DALLOC (EVAL, 'EVAL', 'SCF') + CALL DALLOC (EVEC, 'EvEC', 'SCF') +!GG CALL DALLOC (IATJPO, 'IATJPO', 'SCF') +!GG CALL DALLOC (IASPAR, 'IASPAR', 'SCF') + CALL DALLOC (NCMAXBLK, 'NCMAXBLK', 'SCF') ! getold.f + CALL DALLOC (EAVBLK, 'EAVBLK', 'SCF') ! getold.f + CALL DALLOC (IDXBLK, 'IDXBLK', 'SCF') ! Allocated in getold.f + CALL DALLOC (ICCMIN, 'ICCMIN', 'SCF') ! Allocated in items.f<-getold.f + ENDIF ! - CALL DALLOC (NCFPAST, 'NCFPAST', 'SCF') - CALL DALLOC (NCMINPAST, 'NCMINPAST', 'SCF') - CALL DALLOC (NEVECPAST, 'NEVECPAST', 'SCF') - - 301 FORMAT(/,' Iteration number ',1I3,/,' --------------------') + CALL DALLOC (NCFPAST, 'NCFPAST', 'SCF') + CALL DALLOC (NCMINPAST, 'NCMINPAST', 'SCF') + CALL DALLOC (NEVECPAST, 'NEVECPAST', 'SCF') + + 301 FORMAT(/,' Iteration number ',1I3,/,' --------------------') 302 FORMAT(41X,'Self- Damping'/,& 'Subshell Energy Method P0 ',& - 'consistency Norm-1 factor JP',' MTP INV NNP'/) - - RETURN - END SUBROUTINE SCF + 'consistency Norm-1 factor JP',' MTP INV NNP'/) + + RETURN + END SUBROUTINE SCF diff --git a/src/appl/rmcdhf90/scf_I.f90 b/src/appl/rmcdhf90/scf_I.f90 index fe4a56cd0..3c64ce8be 100644 --- a/src/appl/rmcdhf90/scf_I.f90 +++ b/src/appl/rmcdhf90/scf_I.f90 @@ -1,11 +1,11 @@ - MODULE scf_I + MODULE scf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE scf (EOL, RWFFILE2) - LOGICAL, INTENT(IN) :: EOL - CHARACTER (LEN = *) :: RWFFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE scf (EOL, RWFFILE2) + LOGICAL, INTENT(IN) :: EOL + CHARACTER (LEN = *) :: RWFFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setcof.f90 b/src/appl/rmcdhf90/setcof.f90 index 19ba2bc25..f0bfd8b7a 100644 --- a/src/appl/rmcdhf90/setcof.f90 +++ b/src/appl/rmcdhf90/setcof.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCOF(EOL, J) + SUBROUTINE SETCOF(EOL, J) ! * ! This subroutine sets up the coefficients and orbital pointers * ! for the direct and exchange potentials for orbital J . It also * @@ -14,20 +14,20 @@ SUBROUTINE SETCOF(EOL, J) ! Modified by Xinghong He Last update: 21 Dec 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE orb_C USE hblock_C USE hmat_C USE iounit_C - USE MCPA_C + USE MCPA_C USE mpi_s USE pos_C USE scf_C @@ -35,31 +35,31 @@ SUBROUTINE SETCOF(EOL, J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dsubrs_I - USE fco_I - USE gco_I + USE dsubrs_I + USE fco_I + USE gco_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - LOGICAL :: EOL + INTEGER :: J + LOGICAL :: EOL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB - CHARACTER*6, PARAMETER :: MYNAME = 'SETCOF' + INTEGER, PARAMETER :: KEY = KEYORB + CHARACTER*6, PARAMETER :: MYNAME = 'SETCOF' REAL, PARAMETER :: EPS = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(4) :: INDEXS + INTEGER , DIMENSION(4) :: INDEXS INTEGER :: NDIM, NAKJ, NKJJ, ILABEL, NWTERM, IB, K, NB, IR, NKJIB, KMAX, & KMIN, NFILE, I, JBLOCK, JBLOCKT, IENDCDUM, NCOEFF, IOS, LAB, NCONTR, & IA, IC, ITHIS, IRANK, IIND, IL, IORB, IYO1, IYO2, IFOUND, LOC1, LOC2, & ITHIS2, INDIND, NELMNTGG - REAL(DOUBLE) :: UCFJ, SUMR, YKAB, XKAB, SUM, CONTR - CHARACTER :: MCPLAB*3, IDSTRING*3, MSG*128 + REAL(DOUBLE) :: UCFJ, SUMR, YKAB, XKAB, SUM, CONTR + CHARACTER :: MCPLAB*3, IDSTRING*3, MSG*128 !----------------------------------------------- !** Locals ! POINTER (PCOEFF,COEFF(1)) @@ -95,55 +95,55 @@ SUBROUTINE SETCOF(EOL, J) ! Initializations !======================================================================= - NDIM = 1 - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - - NDCOF = 0 - NXCOF = 0 - NYCOF = 0 - - NAKJ = NAK(J) - NKJJ = NKJ(J) - UCFJ = UCF(J) - + NDIM = 1 + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + + NDCOF = 0 + NXCOF = 0 + NYCOF = 0 + + NAKJ = NAK(J) + NKJJ = NKJ(J) + UCFJ = UCF(J) + !======================================================================= ! Generate YA coefficients that do not require MCP output list. ! Computation distributed and then collected. !======================================================================= - - ILABEL = 0 - NWTERM = KEY*(KEY + 1) - DO IB = 1, NW - ILABEL = ILABEL + NWTERM - IF (IB == J) THEN - KMAX = NKJJ - 1 - ELSE - KMAX = 0 - ENDIF - DO K = 0, KMAX, 2 - + + ILABEL = 0 + NWTERM = KEY*(KEY + 1) + DO IB = 1, NW + ILABEL = ILABEL + NWTERM + IF (IB == J) THEN + KMAX = NKJJ - 1 + ELSE + KMAX = 0 + ENDIF + DO K = 0, KMAX, 2 + !<<< mpi distribute calculation <<<<<<<<<<<<<<<<<<<<<< - SUMR = 0.D0 - DO NB = 1, NBLOCK - DO IR = MYID + 1, NCFBLK(NB), NPROCS + SUMR = 0.D0 + DO NB = 1, NBLOCK + DO IR = MYID + 1, NCFBLK(NB), NPROCS SUMR = SUMR + DSUBRS(EOL,IR,IR,NB)*FCO(K,IR + NCFPAST(NB),J,& - IB) - END DO - END DO + IB) + END DO + END DO !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - IF (IB == J) THEN - YKAB = 2.D0*SUMR/UCFJ - ELSE - YKAB = SUMR/UCFJ - ENDIF - + + IF (IB == J) THEN + YKAB = 2.D0*SUMR/UCFJ + ELSE + YKAB = SUMR/UCFJ + ENDIF + !*** The following IF has to be removed since YKAB !*** is incomplete in multiprocessor case !IF (ABS (YKAB) .GT. EPS) THEN - NYCOF = NYCOF + 1 + NYCOF = NYCOF + 1 IF (NYCOF .GT. NYDIM ) THEN IF (NYDIM .GT. 0) THEN NYDIM = 2*NYDIM @@ -161,420 +161,420 @@ SUBROUTINE SETCOF(EOL, J) ! CALL ALLOC(YA, NYCOF, 'YA', 'SETCOF') ! NYDIM = NYCOF !cjb - ENDIF - ENDIF - YA(NYCOF) = YKAB - NYA(NYCOF) = K + ILABEL + ENDIF + ENDIF + YA(NYCOF) = YKAB + NYA(NYCOF) = K + ILABEL !ENDIF - - END DO - END DO - + + END DO + END DO + !======================================================================= ! Generate XA coefficients that do not require MCP output list ! Computation distributed and then collected. !======================================================================= - - ILABEL = KEY*J - NWTERM = KEY*KEY*(KEY + 1) - DO IB = 1, NW - ILABEL = ILABEL + NWTERM - IF (IB == J) CYCLE - NKJIB = NKJ(IB) - IF (NAKJ*NAK(IB) > 0) THEN - KMIN = ABS((NKJJ - NKJIB)/2) - ELSE - KMIN = ABS((NKJJ - NKJIB)/2) + 1 - ENDIF - KMAX = (NKJJ + NKJIB)/2 - - DO K = KMIN, KMAX, 2 - + + ILABEL = KEY*J + NWTERM = KEY*KEY*(KEY + 1) + DO IB = 1, NW + ILABEL = ILABEL + NWTERM + IF (IB == J) CYCLE + NKJIB = NKJ(IB) + IF (NAKJ*NAK(IB) > 0) THEN + KMIN = ABS((NKJJ - NKJIB)/2) + ELSE + KMIN = ABS((NKJJ - NKJIB)/2) + 1 + ENDIF + KMAX = (NKJJ + NKJIB)/2 + + DO K = KMIN, KMAX, 2 + !<<< mpi distribute calculation <<<<<<<<<<<<<<<<<<<<<< - SUMR = 0.D0 - DO NB = 1, NBLOCK - DO IR = MYID + 1, NCFBLK(NB), NPROCS + SUMR = 0.D0 + DO NB = 1, NBLOCK + DO IR = MYID + 1, NCFBLK(NB), NPROCS SUMR = SUMR + DSUBRS(EOL,IR,IR,NB)*GCO(K,IR + NCFPAST(NB),J,& - IB) - END DO - END DO + IB) + END DO + END DO !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - XKAB = SUMR/UCFJ - + + XKAB = SUMR/UCFJ + !*** The following IF has to be removed since YKAB !*** is incomplete in multiprocessor case !IF (ABS (XKAB) .GT. EPS) THEN - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM !cjb RALLOC ALLOC NXA, XA, (NXDIM NXCOF) - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') ! NXDIM = NXCOF !cjb - ENDIF - ENDIF - XA(NXCOF) = XKAB - NXA(NXCOF) = K + ILABEL + ENDIF + ENDIF + XA(NXCOF) = XKAB + NXA(NXCOF) = K + ILABEL !ENDIF - END DO - END DO - + END DO + END DO + !======================================================================= ! Subroutine setham called from matrix had gone through the mcp ! files once. setcof will do it again. (Go to setmcp to see ! contents of these records. !======================================================================= - - DO NFILE = 30, 32 + KMAXF - REWIND (NFILE) - IF (NFILE /= 30) THEN - DO I = 1, 3 - READ (NFILE) - CYCLE - END DO - ELSE - DO I = 1, 3 - READ (NFILE) - READ (NFILE) - END DO - ENDIF - END DO - + + DO NFILE = 30, 32 + KMAXF + REWIND (NFILE) + IF (NFILE /= 30) THEN + DO I = 1, 3 + READ (NFILE) + CYCLE + END DO + ELSE + DO I = 1, 3 + READ (NFILE) + READ (NFILE) + END DO + ENDIF + END DO + !======================================================================= ! Generate DA coefficients; these arise from the one-electron ! integrals !======================================================================= - - DO JBLOCK = 1, NBLOCK - + + DO JBLOCK = 1, NBLOCK + !*** Read in IROW from file mcp.30 *** - READ (30) MCPLAB, JBLOCKT, NCF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, '1: jblockt .NE. jblock' - STOP - ENDIF + READ (30) MCPLAB, JBLOCKT, NCF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, '1: jblockt .NE. jblock' + STOP + ENDIF READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') - READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - + CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') + READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + !*** Block info file mcp.31 *** - READ (31) MCPLAB, JBLOCKT, NCF, NCOEFF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, '2: jblockt .NE. jblock' - STOP - ENDIF - + READ (31) MCPLAB, JBLOCKT, NCF, NCOEFF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, '2: jblockt .NE. jblock' + STOP + ENDIF + !*** Loop over labels having non-zero coefficients !*** it exits when no more labels for the block - - L123: DO WHILE(.TRUE.) - READ (31, IOSTAT=IOS) LAB, NCONTR - + + L123: DO WHILE(.TRUE.) + READ (31, IOSTAT=IOS) LAB, NCONTR + ! 0, 0 marks the end of a block. This is the normal exit - - IF (LAB==0 .AND. NCONTR==0) THEN - CALL DALLOC (IROW, 'IROW', 'SETCOF') - EXIT ! Actually to next block - ENDIF - + + IF (LAB==0 .AND. NCONTR==0) THEN + CALL DALLOC (IROW, 'IROW', 'SETCOF') + EXIT ! Actually to next block + ENDIF + !*** Decode the labels of I(ab) *** - IA = MOD(LAB,KEY) - IB = LAB/KEY - + IA = MOD(LAB,KEY) + IB = LAB/KEY + ! At least one orbital should be J in order to have ! non-zero value; otherwise, goto next label. - - IF (IA/=J .AND. IB/=J) THEN - READ (31) ! No contributions from this integral; skip - CYCLE ! to next label - ENDIF - - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - ENDIF - + + IF (IA/=J .AND. IB/=J) THEN + READ (31) ! No contributions from this integral; skip + CYCLE ! to next label + ENDIF + + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + ENDIF + ! Read the column index, the sparse matrix index, and the ! coefficient for all contributions from this integral - - READ (31) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) - + + READ (31) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) + ! Add up all the contributions from this integral; ! off-diagonal contributions have double the weight - - SUM = 0.D0 - DO I = 1, NCONTR - IR = IROW(INDX(I)) - IC = ICLMN(I) - - CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) - - IF (IR /= IC) CONTR = CONTR + CONTR - SUM = SUM + CONTR - END DO - SUM = 0.5D0*SUM/UCFJ - + + SUM = 0.D0 + DO I = 1, NCONTR + IR = IROW(INDX(I)) + IC = ICLMN(I) + + CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) + + IF (IR /= IC) CONTR = CONTR + CONTR + SUM = SUM + CONTR + END DO + SUM = 0.5D0*SUM/UCFJ + ! Put coefficients in the list. Since there is always ! (almost) some repetition from different blocks, a check ! and merge is performed. This will significantly reduce ! the NDCOF and thus the number of calls to YZK later. - + !*** Find the right counting parameter *** - IF (IA == J) THEN - ITHIS = IB - ELSE - ITHIS = IA - ENDIF - + IF (IA == J) THEN + ITHIS = IB + ELSE + ITHIS = IA + ENDIF + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NDCOF - IF (NDA(I) /= ITHIS) CYCLE ! found, add the value - DA(I) = DA(I) + SUM - CYCLE L123 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NDCOF + IF (NDA(I) /= ITHIS) CYCLE ! found, add the value + DA(I) = DA(I) + SUM + CYCLE L123 + END DO + ENDIF + !*** Not found in the record, add an item *** - NDCOF = NDCOF + 1 - IF (NDCOF > NDDIM) THEN - IF (NDDIM > 0) THEN + NDCOF = NDCOF + 1 + IF (NDCOF > NDDIM) THEN + IF (NDDIM > 0) THEN NDDIM = 2*NDDIM - CALL RALLOC (DA, NDDIM, 'DA', 'SETCOF') - CALL RALLOC (NDA, NDDIM, 'NDA', 'SETCOF') -! CALL RALLOC (DA, NDCOF, 'DA', 'SETCOF') -! CALL RALLOC (NDA, NDCOF, 'NDA', 'SETCOF') - ELSE + CALL RALLOC (DA, NDDIM, 'DA', 'SETCOF') + CALL RALLOC (NDA, NDDIM, 'NDA', 'SETCOF') +! CALL RALLOC (DA, NDCOF, 'DA', 'SETCOF') +! CALL RALLOC (NDA, NDCOF, 'NDA', 'SETCOF') + ELSE NDDIM = 64 - CALL ALLOC (DA, NDDIM, 'DA', 'SETCOF') - CALL ALLOC (NDA, NDDIM, 'NDA', 'SETCOF') -! CALL ALLOC (DA, NDCOF, 'DA', 'SETCOF') -! CALL ALLOC (NDA, NDCOF, 'NDA', 'SETCOF') + CALL ALLOC (DA, NDDIM, 'DA', 'SETCOF') + CALL ALLOC (NDA, NDDIM, 'NDA', 'SETCOF') +! CALL ALLOC (DA, NDCOF, 'DA', 'SETCOF') +! CALL ALLOC (NDA, NDCOF, 'NDA', 'SETCOF') ! NDDIM = NDCOF - ENDIF - ENDIF - DA(NDCOF) = SUM ! print*, DA(NDCOF), ndcof, myid, 'myid' - NDA(NDCOF) = ITHIS - - END DO L123 ! For labels - END DO ! For blocks - + ENDIF + ENDIF + DA(NDCOF) = SUM ! print*, DA(NDCOF), ndcof, myid, 'myid' + NDA(NDCOF) = ITHIS + + END DO L123 ! For labels + END DO ! For blocks + !======================================================================= ! Generate YA and XA coefficients; these arise from the two-electron ! integrals !======================================================================= - - DO NFILE = 32, 32 + KMAXF - + + DO NFILE = 32, 32 + KMAXF + ! ...Re-position file mcp.30 - - REWIND (30) - DO I = 1, 6 - READ (30) - END DO - + + REWIND (30) + DO I = 1, 6 + READ (30) + END DO + !======================================================================= ! Loop over blocks again, this time, for V-coefficients !======================================================================= - - DO JBLOCK = 1, NBLOCK + + DO JBLOCK = 1, NBLOCK ! ...Read in IROW from file mcp.30 - READ (30) MCPLAB, JBLOCKT, NCF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ':3 jblockt .NE. jblock' - STOP - ENDIF + READ (30) MCPLAB, JBLOCKT, NCF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ':3 jblockt .NE. jblock' + STOP + ENDIF READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') - READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - - READ (NFILE) MCPLAB, JBLOCKT, NCF, NCOEFF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ':4 jblockt .NE. jblock' - STOP - ENDIF - - K = NFILE - 32 ! multipolarity of the integral - + CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') + READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + + READ (NFILE) MCPLAB, JBLOCKT, NCF, NCOEFF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ':4 jblockt .NE. jblock' + STOP + ENDIF + + K = NFILE - 32 ! multipolarity of the integral + !======================================================================= ! Attempt to read another block of data !======================================================================= - - 999 CONTINUE - READ (NFILE, IOSTAT=IOS) LAB, NCONTR + + 999 CONTINUE + READ (NFILE, IOSTAT=IOS) LAB, NCONTR ! - IF (LAB==0 .AND. NCONTR==0) THEN - CALL DALLOC (IROW, 'IROW', 'SETCOF') - CYCLE - ENDIF + IF (LAB==0 .AND. NCONTR==0) THEN + CALL DALLOC (IROW, 'IROW', 'SETCOF') + CYCLE + ENDIF !*** k !*** Decode the labels of R (abcd) - INDEXS(4) = MOD(LAB,KEY) - LAB = LAB/KEY - INDEXS(2) = MOD(LAB,KEY) - LAB = LAB/KEY - INDEXS(3) = MOD(LAB,KEY) - INDEXS(1) = LAB/KEY - + INDEXS(4) = MOD(LAB,KEY) + LAB = LAB/KEY + INDEXS(2) = MOD(LAB,KEY) + LAB = LAB/KEY + INDEXS(3) = MOD(LAB,KEY) + INDEXS(1) = LAB/KEY + !*** Determine the number of indices that match - IRANK = 0 - IRANK = IRANK + COUNT(INDEXS==J) - - IF (IRANK == 0) THEN - READ (NFILE) - GO TO 999 - ENDIF - + IRANK = 0 + IRANK = IRANK + COUNT(INDEXS==J) + + IF (IRANK == 0) THEN + READ (NFILE) + GO TO 999 + ENDIF + !*** At least one subshell index matches; allocate storage !*** for reading in the rest of this block - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF') - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - ENDIF - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF') + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + ENDIF + !*** Read column index, sparse matrix index, and !*** coefficient for all contributions from this integral - READ (NFILE) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) - + READ (NFILE) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) + !*** Add up all the contributions from this integral; !*** off-diagonal contributions have double the weight - SUM = 0.D0 - DO I = 1, NCONTR - IR = IROW(INDX(I)) - IC = ICLMN(I) - CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) - IF (IR /= IC) CONTR = CONTR + CONTR - SUM = SUM + CONTR - END DO - SUM = 0.5D0*SUM/UCFJ - - SELECT CASE (IRANK) - CASE (1) - + SUM = 0.D0 + DO I = 1, NCONTR + IR = IROW(INDX(I)) + IC = ICLMN(I) + CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) + IF (IR /= IC) CONTR = CONTR + CONTR + SUM = SUM + CONTR + END DO + SUM = 0.5D0*SUM/UCFJ + + SELECT CASE (IRANK) + CASE (1) + !======================================================================= ! One matching index: exchange potential contribution !======================================================================= - + !*** Similar to DA, find ithis *** - ITHIS = -911 ! initialize to an impossible value + ITHIS = -911 ! initialize to an impossible value ! though not necessary - DO IIND = 1, 4 - IF (INDEXS(IIND) /= J) CYCLE ! at least one - IL = IIND + 2 - IF (IL > 4) IL = IL - 4 - IORB = INDEXS(IL) - IL = IIND + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - IL = IIND + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - EXIT - END DO - - IF (ITHIS == (-911)) STOP 'ithis .EQ. -911' - + DO IIND = 1, 4 + IF (INDEXS(IIND) /= J) CYCLE ! at least one + IL = IIND + 2 + IF (IL > 4) IL = IL - 4 + IORB = INDEXS(IL) + IL = IIND + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + IL = IIND + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + EXIT + END DO + + IF (ITHIS == (-911)) STOP 'ithis .EQ. -911' + !*** Check ithis against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS) CYCLE - XA(I) = XA(I) + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS) CYCLE + XA(I) = XA(I) + SUM + GO TO 999 + END DO + ENDIF + !*** Not found in records, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM !cjb RALLOC ALLOC NXA, XA, (NXDIM NXCOF) - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') ! NXDIM = NXCOF !cjb - ENDIF - ENDIF - XA(NXCOF) = SUM - NXA(NXCOF) = ITHIS - - CASE (2) - + ENDIF + ENDIF + XA(NXCOF) = SUM + NXA(NXCOF) = ITHIS + + CASE (2) + !======================================================================= ! Two matching indices: either direct or exchange potential ! contribution !======================================================================= - - IFOUND = 0 - DO IIND = 1, 4 - IF (INDEXS(IIND) /= J) CYCLE - IF (IFOUND == 0) THEN - LOC1 = IIND - IFOUND = IFOUND + 1 - ELSE IF (IFOUND == 1) THEN - LOC2 = IIND - EXIT - ENDIF - END DO - - IF (LOC2 - LOC1 == 2) THEN + + IFOUND = 0 + DO IIND = 1, 4 + IF (INDEXS(IIND) /= J) CYCLE + IF (IFOUND == 0) THEN + LOC1 = IIND + IFOUND = IFOUND + 1 + ELSE IF (IFOUND == 1) THEN + LOC2 = IIND + EXIT + ENDIF + END DO + + IF (LOC2 - LOC1 == 2) THEN ! ! Direct contribution ! !*** Find ithis *** - IL = LOC1 + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - IL = LOC1 + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - ITHIS = (IYO2*KEY + IYO1)*KEY + K - + IL = LOC1 + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + IL = LOC1 + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + ITHIS = (IYO2*KEY + IYO1)*KEY + K + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + SUM + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + SUM + SUM + GO TO 999 + END DO + ENDIF + !*** Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM !cjb RALLOC ALLOC NYA, YA, (NYDIM NYCOF) CALL RALLOC(NYA, NYDIM, 'NYA', 'SETCOF') @@ -589,171 +589,171 @@ SUBROUTINE SETCOF(EOL, J) ! CALL ALLOC(YA, NYCOF, 'YA', 'SETCOF') ! NYDIM = NYCOF !cjb - ENDIF - ENDIF - YA(NYCOF) = SUM + SUM - NYA(NYCOF) = ITHIS - - ELSE + ENDIF + ENDIF + YA(NYCOF) = SUM + SUM + NYA(NYCOF) = ITHIS + + ELSE ! ! Exchange contribution ! !*** Find ithis *** - IL = LOC1 + 2 - IF (IL > 4) IL = IL - 4 - IORB = INDEXS(IL) - IL = LOC1 + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - IL = LOC1 + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - + IL = LOC1 + 2 + IF (IL > 4) IL = IL - 4 + IORB = INDEXS(IL) + IL = LOC1 + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + IL = LOC1 + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS) CYCLE - XA(I) = XA(I) + SUM + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS) CYCLE + XA(I) = XA(I) + SUM + SUM + GO TO 999 + END DO + ENDIF + !*** Not found, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM !cjb RALLOC ALLOC NXA, XA, (NXDIM NXCOF) - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') ! NXDIM = NXCOF !cjb - ENDIF - ENDIF - XA(NXCOF) = SUM + SUM - NXA(NXCOF) = ITHIS - - ENDIF - - CASE (3) - + ENDIF + ENDIF + XA(NXCOF) = SUM + SUM + NXA(NXCOF) = ITHIS + + ENDIF + + CASE (3) + !======================================================================= ! Three matching indices: direct and exchange potential contributions !======================================================================= - + !*** Find ithis AND ithis2 - ITHIS = -911 - ITHIS2 = -911 - DO IIND = 1, 4 - IF (INDEXS(IIND) == J) CYCLE - INDIND = INDEXS(IIND) - IYO2 = INDIND - IYO1 = J - ITHIS = (IYO2*KEY + IYO1)*KEY + K - IORB = INDIND - IYO1 = J - IYO2 = J - ITHIS2 = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - END DO - - IF (ITHIS==(-911) .OR. ITHIS2==(-911)) STOP 'ithis2' - + ITHIS = -911 + ITHIS2 = -911 + DO IIND = 1, 4 + IF (INDEXS(IIND) == J) CYCLE + INDIND = INDEXS(IIND) + IYO2 = INDIND + IYO1 = J + ITHIS = (IYO2*KEY + IYO1)*KEY + K + IORB = INDIND + IYO1 = J + IYO2 = J + ITHIS2 = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + END DO + + IF (ITHIS==(-911) .OR. ITHIS2==(-911)) STOP 'ithis2' + !*** Check the previously recorded for YA - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + SUM + SUM - GO TO 456 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + SUM + SUM + GO TO 456 + END DO + ENDIF + ! Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM CALL RALLOC (NYA, NYDIM, 'NYA', 'SETCOF') CALL RALLOC (YA, NYDIM, 'YA', 'SETCOF') ! CALL RALLOC (NYA, NYCOF, 'NYA', 'SETCOF') ! CALL RALLOC (YA, NYCOF, 'YA', 'SETCOF') - ELSE + ELSE NYDIM = 64 CALL ALLOC (NYA, NYDIM, 'NYA', 'SETCOF') CALL ALLOC (YA, NYDIM, 'YA', 'SETCOF') ! CALL ALLOC (NYA, NYCOF, 'NYA', 'SETCOF') ! CALL ALLOC (YA, NYCOF, 'YA', 'SETCOF') ! NYDIM = NYCOF - ENDIF - ENDIF - YA(NYCOF) = SUM + SUM - NYA(NYCOF) = ITHIS - - 456 CONTINUE - + ENDIF + ENDIF + YA(NYCOF) = SUM + SUM + NYA(NYCOF) = ITHIS + + 456 CONTINUE + !*** Check the previously recorded for XA - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS2) CYCLE - XA(I) = XA(I) + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS2) CYCLE + XA(I) = XA(I) + SUM + GO TO 999 + END DO + ENDIF + ! Not found, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM !cjb RALLOC ALLOC NXA, XA, (NXDIM NXCOF) - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') - ELSE - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') -! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') -! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL RALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL RALLOC (NXA, NXCOF, 'NXA', 'SETCOF') + ELSE + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') +! CALL ALLOC (XA, NXCOF, 'XA', 'SETCOF') +! CALL ALLOC (NXA, NXCOF, 'NXA', 'SETCOF') ! NXDIM = NXCOF !cjb - ENDIF - ENDIF - XA(NXCOF) = SUM - NXA(NXCOF) = ITHIS2 - - CASE (4) - + ENDIF + ENDIF + XA(NXCOF) = SUM + NXA(NXCOF) = ITHIS2 + + CASE (4) + !======================================================================= ! Four matching indices: direct potential contribution !======================================================================= - + !*** Find ithis AND ithis2 - IYO2 = J - IYO1 = J - ITHIS = (IYO2*KEY + IYO1)*KEY + K - + IYO2 = J + IYO1 = J + ITHIS = (IYO2*KEY + IYO1)*KEY + K + !*** Check the previously recorded for YA - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + 4.D0*SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + 4.D0*SUM + GO TO 999 + END DO + ENDIF + ! Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM !cjb RALLOC ALLOC NYA, YA, (NYDIM NYCOF) CALL RALLOC(NYA, NYDIM, 'NYA', 'SETCOF') @@ -769,23 +769,23 @@ SUBROUTINE SETCOF(EOL, J) ! CALL ALLOC(YA, NYCOF, 'YA', 'SETCOF') ! NYDIM = NYCOF !cjb - ENDIF - ENDIF - YA(NYCOF) = 4.D0*SUM - NYA(NYCOF) = ITHIS - - END SELECT - - GO TO 999 - END DO ! loop for V-Coefficients - END DO - + ENDIF + ENDIF + YA(NYCOF) = 4.D0*SUM + NYA(NYCOF) = ITHIS + + END SELECT + + GO TO 999 + END DO ! loop for V-Coefficients + END DO + !======================================================================= ! Deallocate storage for arrays local to this routine !======================================================================= - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - - RETURN - END SUBROUTINE SETCOF + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + + RETURN + END SUBROUTINE SETCOF diff --git a/src/appl/rmcdhf90/setcof_I.f90 b/src/appl/rmcdhf90/setcof_I.f90 index 71156324b..f43973acb 100644 --- a/src/appl/rmcdhf90/setcof_I.f90 +++ b/src/appl/rmcdhf90/setcof_I.f90 @@ -1,11 +1,11 @@ - MODULE setcof_I + MODULE setcof_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcof (EOL, J) - LOGICAL :: EOL - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcof (EOL, J) + LOGICAL :: EOL + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setcsl.f90 b/src/appl/rmcdhf90/setcsl.f90 index 5544efabc..f8a1c5daa 100644 --- a/src/appl/rmcdhf90/setcsl.f90 +++ b/src/appl/rmcdhf90/setcsl.f90 @@ -18,13 +18,13 @@ SUBROUTINE SETCSL(NAME, NCORE, IDBLK) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE hblock_C @@ -34,49 +34,49 @@ SUBROUTINE SETCSL(NAME, NCORE, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcsh_I + USE openfl_I + USE lodcsh_I USE lodcsh2gg_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - CHARACTER :: NAME*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: NCORE + CHARACTER :: NAME*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS - CHARACTER :: STR*15 + INTEGER :: IERR, IOS + CHARACTER :: STR*15 !----------------------------------------------- ! ! opens, reads the header of the file - - CALL OPENFL (21, NAME, 'FORMATTED', 'OLD', IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) - STOP - ENDIF - - READ (21, '(1A15)', IOSTAT=IOS) STR - IF (IOS/=0 .OR. STR/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - STOP - ENDIF - + + CALL OPENFL (21, NAME, 'FORMATTED', 'OLD', IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) + STOP + ENDIF + + READ (21, '(1A15)', IOSTAT=IOS) STR + IF (IOS/=0 .OR. STR/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + STOP + ENDIF + !..Load header of file - CALL LODCSH (21, NCORE) - + CALL LODCSH (21, NCORE) + ! Allocate memories for all blocks and then load the entire file - + CALL ALLOC (iqa, NNNW, NCFTOT, 'IQA', 'SETCSL') !GG CALL ALLOC (jqsa, NNNW,3,NCFTOT, 'JQSA', 'SETCSL') !GG CALL ALLOC (jcupa, NNNW, NCFTOT, 'JCUPA', 'SETCSL') - CALL LODCSH2GG (21, NCORE, -119) + CALL LODCSH2GG (21, NCORE, -119) ! -119 means "load all blocks" - - RETURN - END SUBROUTINE SETCSL + + RETURN + END SUBROUTINE SETCSL diff --git a/src/appl/rmcdhf90/setcsl_I.f90 b/src/appl/rmcdhf90/setcsl_I.f90 index 1466b021a..97a52916e 100644 --- a/src/appl/rmcdhf90/setcsl_I.f90 +++ b/src/appl/rmcdhf90/setcsl_I.f90 @@ -1,12 +1,12 @@ - MODULE setcsl_I + MODULE setcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsl (NAME, NCORE, IDBLK) - CHARACTER (LEN = *), INTENT(IN) :: NAME - INTEGER :: NCORE - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcsl (NAME, NCORE, IDBLK) + CHARACTER (LEN = *), INTENT(IN) :: NAME + INTEGER :: NCORE + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setdbg.f90 b/src/appl/rmcdhf90/setdbg.f90 index 7c07ac924..8d2eafddc 100644 --- a/src/appl/rmcdhf90/setdbg.f90 +++ b/src/appl/rmcdhf90/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG(DBGFILE) + SUBROUTINE SETDBG(DBGFILE) ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -11,20 +11,20 @@ SUBROUTINE SETDBG(DBGFILE) ! Modified bu Xinghong He Last update: 06 Jul 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE DEBUG_C + USE DEBUG_C USE default_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I + USE getyn_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -33,117 +33,117 @@ SUBROUTINE SETDBG(DBGFILE) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' - CHARACTER*3, PARAMETER :: STATUS = 'NEW' + CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' + CHARACTER*3, PARAMETER :: STATUS = 'NEW' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, LENDBG, LENFIL, IERR -!GG CHARACTER(LEN=120) :: FILNAM - CHARACTER(LEN = LEN (dbgfile)) :: FILNAM + INTEGER :: I, LENDBG, LENFIL, IERR +!GG CHARACTER(LEN=120) :: FILNAM + CHARACTER(LEN = LEN (dbgfile)) :: FILNAM !----------------------------------------------- ! ! Initialise the arrays that control the debug printout ! These serve as the default settings. ! - LDBPA = .FALSE. - LDBPG = .FALSE. - - LDBPR = .FALSE. + LDBPA = .FALSE. + LDBPG = .FALSE. + + LDBPR = .FALSE. ! - IF (NDEF == 0) RETURN - + IF (NDEF == 0) RETURN + ! Even in non-default, the user can choose not to have debug ! print-out - - WRITE (ISTDE, '(A)', ADVANCE='NO') 'Generate debug output? (y/n) ' - IF (.NOT.GETYN()) RETURN - - LENDBG = LEN_TRIM(DBGFILE) - + + WRITE (ISTDE, '(A)', ADVANCE='NO') 'Generate debug output? (y/n) ' + IF (.NOT.GETYN()) RETURN + + LENDBG = LEN_TRIM(DBGFILE) + WRITE (ISTDE, *) 'File ', DBGFILE(1:LENDBG), & ' will be created as the RSCF92 DeBuG Printout& - & File;' + & File;' WRITE (ISTDE, *) 'enter another file name if this is not', & - ' acceptable; null otherwise:' - - 123 CONTINUE - READ (*, '(A)') FILNAM - - FILNAM = ADJUSTL(FILNAM) - LENFIL = LEN_TRIM(FILNAM) - IF (LENFIL == 0) THEN - FILNAM = DBGFILE - ELSE IF (LENFIL > LENDBG) THEN - WRITE (ISTDE, *) 'File name too long, (> ', LENDBG, '); redo...' - GO TO 123 - ENDIF - - CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'File name not accepted; redo...' - GO TO 123 - ENDIF + ' acceptable; null otherwise:' + + 123 CONTINUE + READ (*, '(A)') FILNAM + + FILNAM = ADJUSTL(FILNAM) + LENFIL = LEN_TRIM(FILNAM) + IF (LENFIL == 0) THEN + FILNAM = DBGFILE + ELSE IF (LENFIL > LENDBG) THEN + WRITE (ISTDE, *) 'File name too long, (> ', LENDBG, '); redo...' + GO TO 123 + ENDIF + + CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'File name not accepted; redo...' + GO TO 123 + ENDIF ! ! Set options for general printout ! - WRITE (ISTDE, *) 'Print out the machine constants used?' - LDBPG(1) = GETYN() - WRITE (ISTDE, *) 'Print out the physical constants used?' - LDBPG(2) = GETYN() - WRITE (ISTDE, *) 'Printout from FNDBLK?' - LDBPG(3) = GETYN() - WRITE (ISTDE, *) 'Print out the Hamiltonian matrix?' - LDBPG(4) = GETYN() - WRITE (ISTDE, *) 'Print out the eigenvectors?' - LDBPG(5) = GETYN() - LDBPG(1:5) = .TRUE. + WRITE (ISTDE, *) 'Print out the machine constants used?' + LDBPG(1) = GETYN() + WRITE (ISTDE, *) 'Print out the physical constants used?' + LDBPG(2) = GETYN() + WRITE (ISTDE, *) 'Printout from FNDBLK?' + LDBPG(3) = GETYN() + WRITE (ISTDE, *) 'Print out the Hamiltonian matrix?' + LDBPG(4) = GETYN() + WRITE (ISTDE, *) 'Print out the eigenvectors?' + LDBPG(5) = GETYN() + LDBPG(1:5) = .TRUE. ! ! Set options for printout from radial modules ! - WRITE (ISTDE, *) 'Printout from RADGRD?' - LDBPR(1) = GETYN() - WRITE (ISTDE, *) 'Printout from NUCPOT?' - LDBPR(2) = GETYN() - WRITE (ISTDE, *) 'Printout from LODRWF?' - LDBPR(3) = GETYN() - WRITE (ISTDE, *) 'Print out I(ab) integrals?' - LDBPR(4) = GETYN() - WRITE (ISTDE, *) 'Print out Slater integrals?' - LDBPR(10) = GETYN() + WRITE (ISTDE, *) 'Printout from RADGRD?' + LDBPR(1) = GETYN() + WRITE (ISTDE, *) 'Printout from NUCPOT?' + LDBPR(2) = GETYN() + WRITE (ISTDE, *) 'Printout from LODRWF?' + LDBPR(3) = GETYN() + WRITE (ISTDE, *) 'Print out I(ab) integrals?' + LDBPR(4) = GETYN() + WRITE (ISTDE, *) 'Print out Slater integrals?' + LDBPR(10) = GETYN() WRITE (ISTDE, *) 'Make summary printout on progress', & - ' of each iteration in SOLVE?' - LDBPR(22) = GETYN() + ' of each iteration in SOLVE?' + LDBPR(22) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions on', ' each iteration in SOLVE?' - LDBPR(23) = GETYN() + ' of subshell radial functions on', ' each iteration in SOLVE?' + LDBPR(23) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions', ' after each SCF cycle?' - LDBPR(24) = GETYN() + ' of subshell radial functions', ' after each SCF cycle?' + LDBPR(24) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions on', ' convergence?' - LDBPR(25) = GETYN() - WRITE (ISTDE, *) 'List compositions of exchange', ' potentials?' - LDBPR(27) = GETYN() + ' of subshell radial functions on', ' convergence?' + LDBPR(25) = GETYN() + WRITE (ISTDE, *) 'List compositions of exchange', ' potentials?' + LDBPR(27) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of exchange potentials?' - LDBPR(28) = GETYN() - WRITE (ISTDE, *) 'List compositions of direct', ' potentials?' - LDBPR(29) = GETYN() + ' of exchange potentials?' + LDBPR(28) = GETYN() + WRITE (ISTDE, *) 'List compositions of direct', ' potentials?' + LDBPR(29) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of direct potentials?' - LDBPR(30) = GETYN() - LDBPR(1:30) = .TRUE. + ' of direct potentials?' + LDBPR(30) = GETYN() + LDBPR(1:30) = .TRUE. ! ! Set options for printout of angular coefficients ! - WRITE (ISTDE, *) ' Printout from LODCSL?' - LDBPA(1) = GETYN() - WRITE (ISTDE, *) ' Print out T coefficients?' - LDBPA(2) = GETYN() - WRITE (ISTDE, *) ' Print out V coefficients?' - LDBPA(3) = GETYN() - LDBPA(1:3) = .TRUE. - - RETURN - END SUBROUTINE SETDBG + WRITE (ISTDE, *) ' Printout from LODCSL?' + LDBPA(1) = GETYN() + WRITE (ISTDE, *) ' Print out T coefficients?' + LDBPA(2) = GETYN() + WRITE (ISTDE, *) ' Print out V coefficients?' + LDBPA(3) = GETYN() + LDBPA(1:3) = .TRUE. + + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rmcdhf90/setdbg_I.f90 b/src/appl/rmcdhf90/setdbg_I.f90 index 9ac39f36a..6f8eb89ae 100644 --- a/src/appl/rmcdhf90/setdbg_I.f90 +++ b/src/appl/rmcdhf90/setdbg_I.f90 @@ -1,10 +1,10 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setdbg (DBGFILE) - CHARACTER (LEN = *), INTENT(IN) :: DBGFILE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg (DBGFILE) + CHARACTER (LEN = *), INTENT(IN) :: DBGFILE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setham.f90 b/src/appl/rmcdhf90/setham.f90 index dca960cba..4b68efddb 100644 --- a/src/appl/rmcdhf90/setham.f90 +++ b/src/appl/rmcdhf90/setham.f90 @@ -1,13 +1,13 @@ !*********************************************************************** ! * - SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) + SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE, LONG USE parameter_def, ONLY: KEYORB @@ -16,39 +16,39 @@ SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) ! C O M M O N B l o c k s !----------------------------------------------- USE hmat_C - USE MCPA_C + USE MCPA_C USE orb_C USE pos_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE rinti_I - USE fco_I - USE slater_I - USE gco_I + USE iq_I + USE rinti_I + USE fco_I + USE slater_I + USE gco_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: MYID, NPROCS + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: MYID, NPROCS !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB - CHARACTER*6, PARAMETER :: MYNAME = 'SETHAM' + INTEGER, PARAMETER :: KEY = KEYORB + CHARACTER*6, PARAMETER :: MYNAME = 'SETHAM' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NCFPAT, IA, IR, ITMP, IDIAG, KM, K, K0, IB, NKJIA, NKJIB, KMIN& , KMAX, NDIM, JBLOCKT, NCFT, NCOEFF, IOS, LAB, NCONTR, ICLMNDUM, I, & - LOC, NFILE, ID, IC + LOC, NFILE, ID, IC INTEGER(LONG) :: LOD ! INTEGER*8 version of LOC - REAL(DOUBLE) :: DIAA, COEF, F0AA, FKAA, F0AB, GKAB, TEGRAL - LOGICAL :: SET - CHARACTER :: MCPLAB*3 + REAL(DOUBLE) :: DIAA, COEF, F0AA, FKAA, F0AB, GKAB, TEGRAL + LOGICAL :: SET + CHARACTER :: MCPLAB*3 REAL(DOUBLE), DIMENSION(:), POINTER :: coeff INTEGER, DIMENSION(:), POINTER :: indx !----------------------------------------------- @@ -71,282 +71,282 @@ SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) ! POINTER (PINDX,INDX(1)) ! !----------------------------------------------------------------------- - NCFPAT = NCFPAST(JBLOCK) + NCFPAT = NCFPAST(JBLOCK) !======================================================================= ! Accumulate diagonal terms that do not require MCP coefficients !======================================================================= - + !======================================================================= ! Piece involving I(a,a) integrals !======================================================================= - - DO IA = 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - ITMP = IQ(IA,IR + NCFPAT) - IF (ITMP <= 0) CYCLE + + DO IA = 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + ITMP = IQ(IA,IR + NCFPAT) + IF (ITMP <= 0) CYCLE !*** Occupation number not zero ... - IF (.NOT.SET) THEN - DIAA = RINTI(IA,IA,0) - SET = .TRUE. - ENDIF + IF (.NOT.SET) THEN + DIAA = RINTI(IA,IA,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) ! lower-triangle-by-rows mode - EMT(IDIAG) = EMT(IDIAG) + ITMP*DIAA - END DO - END DO - + IDIAG = IENDC(IR) ! lower-triangle-by-rows mode + EMT(IDIAG) = EMT(IDIAG) + ITMP*DIAA + END DO + END DO + !======================================================================= ! 0 ! Piece involving F (a,a) integrals !======================================================================= - - DO IA = 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(0,IR + NCFPAT,IA,IA) - IF (COEF == 0.D0) CYCLE + + DO IA = 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(0,IR + NCFPAT,IA,IA) + IF (COEF == 0.D0) CYCLE !*** Angular coefficient not zero ... - IF (.NOT.SET) THEN - F0AA = SLATER(IA,IA,IA,IA,0) - SET = .TRUE. - ENDIF + IF (.NOT.SET) THEN + F0AA = SLATER(IA,IA,IA,IA,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*F0AA - END DO - END DO - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*F0AA + END DO + END DO + !======================================================================= ! k ! Piece involving F (a,a) integrals !======================================================================= - - KM = 0 - K = 0 - 6 CONTINUE - K = K + 2 - DO IA = 1, NW - K0 = NKJ(IA) - 1 - KM = MAX0(K0,KM) - IF (K > K0) CYCLE - SET = .FALSE. - - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(K,IR + NCFPAT,IA,IA) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - FKAA = SLATER(IA,IA,IA,IA,K) - SET = .TRUE. - ENDIF + + KM = 0 + K = 0 + 6 CONTINUE + K = K + 2 + DO IA = 1, NW + K0 = NKJ(IA) - 1 + KM = MAX0(K0,KM) + IF (K > K0) CYCLE + SET = .FALSE. + + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(K,IR + NCFPAT,IA,IA) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + FKAA = SLATER(IA,IA,IA,IA,K) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*FKAA - END DO - END DO - IF (K < KM) GO TO 6 - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*FKAA + END DO + END DO + IF (K < KM) GO TO 6 + !======================================================================= ! 0 ! Piece involving F (a,b) integrals !======================================================================= - - DO IA = 1, NW - 1 - DO IB = IA + 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(0,IR + NCFPAT,IA,IB) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - F0AB = SLATER(IA,IB,IA,IB,0) - SET = .TRUE. - ENDIF + + DO IA = 1, NW - 1 + DO IB = IA + 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(0,IR + NCFPAT,IA,IB) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + F0AB = SLATER(IA,IB,IA,IB,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*F0AB - END DO - END DO - END DO - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*F0AB + END DO + END DO + END DO + !======================================================================= ! k ! Piece involving G (a,b) integrals !======================================================================= - - KM = 0 - K = -1 - 12 CONTINUE - K = K + 1 - DO IA = 1, NW - 1 - NKJIA = NKJ(IA) - DO IB = IA + 1, NW - NKJIB = NKJ(IB) - SET = .FALSE. - IF (NAK(IA)*NAK(IB) > 0) THEN - KMIN = ABS((NKJIA - NKJIB)/2) - ELSE - KMIN = ABS((NKJIA - NKJIB)/2) + 1 - ENDIF - IF (MOD(K - KMIN,2) /= 0) CYCLE - - KMAX = (NKJIA + NKJIB)/2 - KM = MAX0(KMAX,KM) - IF (KKMAX) CYCLE - - DO IR = MYID + 1, NCF, NPROCS - COEF = GCO(K,IR + NCFPAT,IA,IB) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - GKAB = SLATER(IA,IB,IB,IA,K) - SET = .TRUE. - ENDIF + + KM = 0 + K = -1 + 12 CONTINUE + K = K + 1 + DO IA = 1, NW - 1 + NKJIA = NKJ(IA) + DO IB = IA + 1, NW + NKJIB = NKJ(IB) + SET = .FALSE. + IF (NAK(IA)*NAK(IB) > 0) THEN + KMIN = ABS((NKJIA - NKJIB)/2) + ELSE + KMIN = ABS((NKJIA - NKJIB)/2) + 1 + ENDIF + IF (MOD(K - KMIN,2) /= 0) CYCLE + + KMAX = (NKJIA + NKJIB)/2 + KM = MAX0(KMAX,KM) + IF (KKMAX) CYCLE + + DO IR = MYID + 1, NCF, NPROCS + COEF = GCO(K,IR + NCFPAT,IA,IB) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + GKAB = SLATER(IA,IB,IB,IA,K) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*GKAB - END DO - END DO - END DO - IF (K < KM) GO TO 12 - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*GKAB + END DO + END DO + END DO + IF (K < KM) GO TO 12 + !======================================================================= ! Local storage for reading mcpXXX files !======================================================================= - - NDIM = 1 - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM' ) - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - + + NDIM = 1 + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM' ) + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + !======================================================================= ! Accumulate one-electron terms that require MCP coefficients !======================================================================= - - READ (31) MCPLAB, JBLOCKT, NCFT, NCOEFF - - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ': blk1=', JBLOCKT, ' blk2=', JBLOCK - STOP - ENDIF - IF (NCFT /= NCF) THEN - WRITE (ISTDE, *) MYNAME, ': ncf1 = ', NCFT, ' ncf2 = ', NCF - STOP - ENDIF - + + READ (31) MCPLAB, JBLOCKT, NCFT, NCOEFF + + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ': blk1=', JBLOCKT, ' blk2=', JBLOCK + STOP + ENDIF + IF (NCFT /= NCF) THEN + WRITE (ISTDE, *) MYNAME, ': ncf1 = ', NCFT, ' ncf2 = ', NCF + STOP + ENDIF + !======================================================================= ! Loop over non-zero labels which have non-zero elements !======================================================================= - - READ (31, IOSTAT=IOS) LAB, NCONTR - IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR' - DO WHILE(LAB/=0 .OR. NCONTR/=0) - + + READ (31, IOSTAT=IOS) LAB, NCONTR + IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR' + DO WHILE(LAB/=0 .OR. NCONTR/=0) + !*** decode the label of I(ab) - IA = MOD(LAB,KEY) - IB = LAB/KEY - + IA = MOD(LAB,KEY) + IB = LAB/KEY + !*** Compute radial integral I(ab) - TEGRAL = RINTI(IA,IB,0) - + TEGRAL = RINTI(IA,IB,0) + ! Read column index, sparse matrix index, and coefficient ! for all contributions from this integral. - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - ENDIF - READ (31) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + ENDIF + READ (31) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) + !*** Store all the contributions from this integral - DO I = 1, NCONTR - LOC = INDX(I) + DO I = 1, NCONTR + LOC = INDX(I) LOD = LOC ! (Convert type) - IF (LOD > NELMNT) THEN - WRITE (6, *) ' Error in computing 1-e contribution' + IF (LOD > NELMNT) THEN + WRITE (6, *) ' Error in computing 1-e contribution' WRITE (6, *) ' LOC = ', LOC , ' NELMNT = ', NELMNT - STOP - ENDIF - EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) - END DO - - READ (31, IOSTAT=IOS) LAB, NCONTR - IF (IOS == 0) CYCLE - STOP 'IOS .NE. 0 when reading LAB, NCONTR' - END DO + STOP + ENDIF + EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) + END DO + + READ (31, IOSTAT=IOS) LAB, NCONTR + IF (IOS == 0) CYCLE + STOP 'IOS .NE. 0 when reading LAB, NCONTR' + END DO !======================================================================= ! Accumulate two-electron terms that require MCP coefficients !======================================================================= - - DO NFILE = 32, 32 + KMAXF - K = NFILE - 32 - - READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF - - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ': blk3=', JBLOCKT, ' blk4=', JBLOCK - STOP - ENDIF - IF (NCFT /= NCF) THEN - WRITE (ISTDE, *) MYNAME, ': ncf3 = ', NCFT, ' ncf4 = ', NCF - STOP - ENDIF - + + DO NFILE = 32, 32 + KMAXF + K = NFILE - 32 + + READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF + + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ': blk3=', JBLOCKT, ' blk4=', JBLOCK + STOP + ENDIF + IF (NCFT /= NCF) THEN + WRITE (ISTDE, *) MYNAME, ': ncf3 = ', NCFT, ' ncf4 = ', NCF + STOP + ENDIF + !======================================================================= ! Loop over non-zero labels which have non-zero elements !======================================================================= - - READ (NFILE, IOSTAT=IOS) LAB, NCONTR - IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' - DO WHILE(LAB/=0 .OR. NCONTR/=0) - + + READ (NFILE, IOSTAT=IOS) LAB, NCONTR + IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' + DO WHILE(LAB/=0 .OR. NCONTR/=0) + ! k !*** decode the label of R (abcd) - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY - + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY + !*** Compute radial integral - TEGRAL = SLATER(IA,IB,IC,ID,K) - + TEGRAL = SLATER(IA,IB,IC,ID,K) + ! Read column index, sparse matrix index, and coefficient ! for all contributions from this integral. - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - ENDIF - READ (NFILE) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + ENDIF + READ (NFILE) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) + !*** Store all the contributions from this integral - DO I = 1, NCONTR - LOC = INDX(I) + DO I = 1, NCONTR + LOC = INDX(I) LOD = LOC IF (LOD > NELMNT) THEN !! NELMENT (from Hmat_C) is INT*8 - WRITE (6, *) ' Error in computing 2-e contribution' + WRITE (6, *) ' Error in computing 2-e contribution' WRITE (6, *) ' LOC= ', LOC , ' NELMNT = ', NELMNT - STOP - ENDIF - EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) - END DO - - READ (NFILE, IOSTAT=IOS) LAB, NCONTR - IF (IOS == 0) CYCLE - STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' - END DO - END DO - + STOP + ENDIF + EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) + END DO + + READ (NFILE, IOSTAT=IOS) LAB, NCONTR + IF (IOS == 0) CYCLE + STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' + END DO + END DO + !======================================================================= ! Deallocate local storage !======================================================================= - - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - - RETURN - END SUBROUTINE SETHAM + + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + + RETURN + END SUBROUTINE SETHAM diff --git a/src/appl/rmcdhf90/setham_I.f90 b/src/appl/rmcdhf90/setham_I.f90 index 8263cf9e3..a73508c54 100644 --- a/src/appl/rmcdhf90/setham_I.f90 +++ b/src/appl/rmcdhf90/setham_I.f90 @@ -1,12 +1,12 @@ - MODULE setham_I + MODULE setham_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setham (JBLOCK, MYID, NPROCS) - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setham (JBLOCK, MYID, NPROCS) + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setlag.f90 b/src/appl/rmcdhf90/setlag.f90 index 54f359559..a35f8337d 100644 --- a/src/appl/rmcdhf90/setlag.f90 +++ b/src/appl/rmcdhf90/setlag.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETLAG(EOL) + SUBROUTINE SETLAG(EOL) ! * ! Sets up the data structure pertaining to the Lagrange multipli- * ! ers on the first entry; on subsequent calls it determines new * @@ -13,16 +13,16 @@ SUBROUTINE SETLAG(EOL) ! MPI version by Xinghong He Last update: 03 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man - USE ORBA_C + USE ORBA_C USE core_C USE def_C USE fixd_C @@ -37,38 +37,38 @@ SUBROUTINE SETLAG(EOL) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcof_I - USE ypot_I - USE xpot_I - USE dacon_I - USE quad_I - USE rinti_I + USE setcof_I + USE ypot_I + USE xpot_I + USE dacon_I + USE quad_I + USE rinti_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL :: EOL + LOGICAL :: EOL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P001 = 1.0D-01 - INTEGER, PARAMETER :: KEY = KEYORB + REAL(DOUBLE), PARAMETER :: P001 = 1.0D-01 + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, & - JLAST, MLAST, M, J, I - REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM - REAL(DOUBLE) :: EPS, UCFJ, UCFM, RESULT, RIJM, QDIF, OBQDIF, OBQSUM - LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ + JLAST, MLAST, M, J, I + REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM + REAL(DOUBLE) :: EPS, UCFJ, UCFM, RESULT, RIJM, QDIF, OBQDIF, OBQSUM + LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ !----------------------------------------------- ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! !----------------------------------------------------------------------- - - IF (FIRST) THEN - + + IF (FIRST) THEN + !======================================================================= ! Determine the total number of Lagrange multipliers and store ! their indeces in IECC(1:NEC). Memories are allocated for IECC @@ -81,48 +81,48 @@ SUBROUTINE SETLAG(EOL) ! ! This part is not distributed. !======================================================================= - - EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied - DO ITWICE = 1, 2 - NEC = 0 -! IF (ITWICE /= 2) THEN -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS + + EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied + DO ITWICE = 1, 2 + NEC = 0 +! IF (ITWICE /= 2) THEN +! DO LIRAW = 1, NW - 1 +! LI = IORDER(LIRAW) +! LIP1 = MAX(NCORE,LIRAW) + 1 +! NAKLI = NAK(LI) +! FIXLI = LFIX(LI) +! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS +! DO LJRAW = LIP1, NW +! LJ = IORDER(LJRAW) +! FIXLJ = LFIX(LJ) +! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS ! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! CYCLE +! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE +! NEC = NEC + 1 +! CYCLE ! !*** Encode index at 2nd round *** -! END DO -! END DO -! ELSE -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS +! END DO +! END DO +! ELSE +! DO LIRAW = 1, NW - 1 +! LI = IORDER(LIRAW) +! LIP1 = MAX(NCORE,LIRAW) + 1 +! NAKLI = NAK(LI) +! FIXLI = LFIX(LI) +! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS ! !*** Encode index at 2nd round *** -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS +! DO LJRAW = LIP1, NW +! LJ = IORDER(LJRAW) +! FIXLJ = LFIX(LJ) +! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS ! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 +! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE +! NEC = NEC + 1 ! !*** Encode index at 2nd round *** -! IECC(NEC) = LI + KEY*LJ -! END DO -! END DO -! ENDIF +! IECC(NEC) = LI + KEY*LJ +! END DO +! END DO +! ENDIF DO LIraw = 1, NW - 1 LI = iorder(LIraw) LIP1 = MAX (NCORE, LIraw) + 1 @@ -144,87 +144,87 @@ SUBROUTINE SETLAG(EOL) ENDDO - IF (ITWICE==1 .AND. NEC>0) THEN - CALL ALLOC (ECV, NEC, 'ECV', 'SETLAG') - CALL ALLOC (IECC, NEC, 'IECC', 'SETLAG') - ELSE - EXIT - ENDIF - END DO !itwice - + IF (ITWICE==1 .AND. NEC>0) THEN + CALL ALLOC (ECV, NEC, 'ECV', 'SETLAG') + CALL ALLOC (IECC, NEC, 'IECC', 'SETLAG') + ELSE + EXIT + ENDIF + END DO !itwice + !======================================================================= ! Print information about Lagrange multipliers !======================================================================= - - IF (MYID == 0) THEN - IF (NEC == 0) THEN - WRITE (*, 302) - ELSE - WRITE (*, 304) - DO LI = 1, NEC + + IF (MYID == 0) THEN + IF (NEC == 0) THEN + WRITE (*, 302) + ELSE + WRITE (*, 304) + DO LI = 1, NEC !*** Decode index *** - IECCLI = IECC(LI) - L1 = IECCLI/KEY - L2 = IECCLI - KEY*L1 - WRITE (*, 305) NP(L2), NH(L2), NP(L1), NH(L1) - END DO - ENDIF - ENDIF - FIRST = .FALSE. - ENDIF - + IECCLI = IECC(LI) + L1 = IECCLI/KEY + L2 = IECCLI - KEY*L1 + WRITE (*, 305) NP(L2), NH(L2), NP(L1), NH(L1) + END DO + ENDIF + ENDIF + FIRST = .FALSE. + ENDIF + !FF+GG 12/07/05 ! Lagrange multipliers need to be computed also on the first call ! RETURN - - IF (NEC == 0) RETURN - IF (MYID == 0) WRITE (*, 306) - JLAST = 0 - MLAST = 0 - - DO LI = 1, NEC + + IF (NEC == 0) RETURN + IF (MYID == 0) WRITE (*, 306) + JLAST = 0 + MLAST = 0 + + DO LI = 1, NEC !*** Decode index *** - IECCLI = IECC(LI) - M = IECCLI/KEY - J = IECCLI - KEY*M + IECCLI = IECC(LI) + M = IECCLI/KEY + J = IECCLI - KEY*M ! - IF (J /= JLAST) THEN - UCFJ = UCF(J) - CALL SETCOF (EOL, J) - CALL YPOT (J) - CALL XPOT (J) - CALL DACON - YPJ(:N) = YP(:N) - XPJ(:N) = XP(:N) - XQJ(:N) = XQ(:N) - JLAST = J - ENDIF + IF (J /= JLAST) THEN + UCFJ = UCF(J) + CALL SETCOF (EOL, J) + CALL YPOT (J) + CALL XPOT (J) + CALL DACON + YPJ(:N) = YP(:N) + XPJ(:N) = XP(:N) + XQJ(:N) = XQ(:N) + JLAST = J + ENDIF ! - IF (M /= MLAST) THEN - UCFM = UCF(M) - CALL SETCOF (EOL, M) - CALL YPOT (M) - CALL XPOT (M) - CALL DACON - YPM(:N) = YP(:N) - XPM(:N) = XP(:N) - XQM(:N) = XQ(:N) - MLAST = M - ENDIF + IF (M /= MLAST) THEN + UCFM = UCF(M) + CALL SETCOF (EOL, M) + CALL YPOT (M) + CALL XPOT (M) + CALL DACON + YPM(:N) = YP(:N) + XPM(:N) = XP(:N) + XQM(:N) = XQ(:N) + MLAST = M + ENDIF ! - MTP = MAX(MF(J),MF(M)) + MTP = MAX(MF(J),MF(M)) ! - IF (LFIX(M)) THEN - TA(1) = 0.D0 - DO I = 2, MTP + IF (LFIX(M)) THEN + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I& - ,J)+QF(I,M)*QF(I,J))*YPJ(I)) - END DO - - CALL QUAD (RESULT) - RIJM = RINTI(M,J,1) - ECV(LI) = (RESULT - RIJM)*UCFJ - + ,J)+QF(I,M)*QF(I,J))*YPJ(I)) + END DO + + CALL QUAD (RESULT) + RIJM = RINTI(M,J,1) + ECV(LI) = (RESULT - RIJM)*UCFJ + ! start dbg ! WRITE (81,*)'1, RESULT, RIJM, UCFJ, ECV, TA' ! dbg ! WRITE (81,*)RESULT, RIJM, UCFJ, ECV ! dbg @@ -232,14 +232,14 @@ SUBROUTINE SETLAG(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! dbg ! ENDDO ! dbg ! end dbg - - ELSE IF (LFIX(J)) THEN - TA(1) = 0.D0 - DO I = 2, MTP + + ELSE IF (LFIX(J)) THEN + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I& - ,M)+QF(I,J)*QF(I,M))*YPM(I)) - END DO - + ,M)+QF(I,J)*QF(I,M))*YPM(I)) + END DO + !start dbg ! DO i = 1, MTP ! WRITE (81,*) i, TA(i) @@ -249,29 +249,29 @@ SUBROUTINE SETLAG(EOL) ! write(86,*)i,xpm(i),xqm(i) ! ENDDO ! end dbg - CALL QUAD (RESULT) - - RIJM = RINTI(J,M,1) !/ nprocs - ECV(LI) = (RESULT - RIJM)*UCFM + CALL QUAD (RESULT) + + RIJM = RINTI(J,M,1) !/ nprocs + ECV(LI) = (RESULT - RIJM)*UCFM !start dbg ! WRITE (81,*)'2, RESULT, RIJM, UCFM, ECV, TA' ! WRITE (81,*)RESULT, RIJM, UCFJ, ECV, r(i), rp(i) !end dbg - - - ELSE - QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) - IF (QDIF > P001) THEN - OBQDIF = 1.D0/UCFJ - 1.D0/UCFM - TA(1) = 0.D0 - DO I = 2, MTP + + + ELSE + QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) + IF (QDIF > P001) THEN + OBQDIF = 1.D0/UCFJ - 1.D0/UCFM + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I& )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) - END DO - - CALL QUAD (RESULT) - ECV(LI) = RESULT/OBQDIF + M)*QF(I,J))) + END DO + + CALL QUAD (RESULT) + ECV(LI) = RESULT/OBQDIF !start dbg ! WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA' ! WRITE (81,*)RESULT, OBQDIF, ECV @@ -279,20 +279,20 @@ SUBROUTINE SETLAG(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! ENDDO !end dbg - - - ELSE - OBQSUM = 1.D0/UCFJ + 1.D0/UCFM - TA(1) = 0.D0 - DO I = 2, MTP + + + ELSE + OBQSUM = 1.D0/UCFJ + 1.D0/UCFM + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I& )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) - END DO - - CALL QUAD (RESULT) - RIJM = RINTI(M,J,1) !/ nprocs - ECV(LI) = (RESULT - 2.D0*RIJM)/OBQSUM + M)*QF(I,J))) + END DO + + CALL QUAD (RESULT) + RIJM = RINTI(M,J,1) !/ nprocs + ECV(LI) = (RESULT - 2.D0*RIJM)/OBQSUM !start dbg ! WRITE (81,*)'4, RESULT, RIUJM, OBQSUM, ECV, TA' ! WRITE (81,*)RESULT, RIUJM, OBQSUM, ECV @@ -300,23 +300,23 @@ SUBROUTINE SETLAG(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! ENDDO !end dbg - - ENDIF - ENDIF - - WRITE (*, 307) NP(J), NH(J), NP(M), NH(M), ECV(LI) - - END DO - + + ENDIF + ENDIF + + WRITE (*, 307) NP(J), NH(J), NP(M), NH(M), ECV(LI) + + END DO + !db close(81) !db close(82) - - - 302 FORMAT(/,'Lagrange multipliers are not required') - 304 FORMAT(/,'Include Lagrange multipliers between:'/) - 305 FORMAT(13X,2(2X,1I2,1A2)) - 306 FORMAT(/,'Lagrange multipliers:'/) - 307 FORMAT(13X,2(2X,1I2,1A2),2X,1P,D16.9) - - RETURN - END SUBROUTINE SETLAG + + + 302 FORMAT(/,'Lagrange multipliers are not required') + 304 FORMAT(/,'Include Lagrange multipliers between:'/) + 305 FORMAT(13X,2(2X,1I2,1A2)) + 306 FORMAT(/,'Lagrange multipliers:'/) + 307 FORMAT(13X,2(2X,1I2,1A2),2X,1P,D16.9) + + RETURN + END SUBROUTINE SETLAG diff --git a/src/appl/rmcdhf90/setlag_I.f90 b/src/appl/rmcdhf90/setlag_I.f90 index 385cf2727..f4e8efcc2 100644 --- a/src/appl/rmcdhf90/setlag_I.f90 +++ b/src/appl/rmcdhf90/setlag_I.f90 @@ -1,11 +1,11 @@ - MODULE setlag_I + MODULE setlag_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setlag (EOL) - LOGICAL :: EOL + SUBROUTINE setlag (EOL) + LOGICAL :: EOL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setmcp.f90 b/src/appl/rmcdhf90/setmcp.f90 index 4c786d374..34df712b6 100644 --- a/src/appl/rmcdhf90/setmcp.f90 +++ b/src/appl/rmcdhf90/setmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** - - SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) + + SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) ! ! Open, read, check the header of all .mcp files. Info for each ! block is not accessed here. @@ -29,17 +29,17 @@ SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) ! Modified by Xinghong He Last revision: 06 Aug 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE DEF_C USE FOPARM_C - USE MCPA_C + USE MCPA_C USE MCPB_C USE mpi_s USE orb_C @@ -48,102 +48,102 @@ SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - INTEGER , INTENT(IN) :: NBLKIN - CHARACTER , INTENT(IN) :: FILEHEAD*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: NCORE + INTEGER , INTENT(IN) :: NBLKIN + CHARACTER , INTENT(IN) :: FILEHEAD*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENFH, IERROR, IOS, I, K, LCK, MYIDD, NPROCSS - LOGICAL :: FOUND, FOUND1 - CHARACTER :: CK*2, MCPLAB*3 + INTEGER :: LENFH, IERROR, IOS, I, K, LCK, MYIDD, NPROCSS + LOGICAL :: FOUND, FOUND1 + CHARACTER :: CK*2, MCPLAB*3 CHARACTER(LEN=120) :: FILNAM !----------------------------------------------- ! - LENFH = LEN_TRIM(FILEHEAD) - - FILNAM = FILEHEAD(1:LENFH)//'.30' + LENFH = LEN_TRIM(FILEHEAD) + + FILNAM = FILEHEAD(1:LENFH)//'.30' OPEN(30, FILE=FILNAM, FORM='UNFORMATTED', STATUS='OLD', IOSTAT=IERROR, & - POSITION='asis') - + POSITION='asis') + ! Parameter ierror carries through mcp.30,... mcp.kmax - - READ (30, IOSTAT=IOS) NCORE, NBLOCK, KMAXF - IERROR = IERROR + ABS(IOS) - IF (NBLOCK>NBLKIN .OR. NBLOCK<1) THEN - WRITE (ISTDE, *) 'setmcp: nblock = ', NBLOCK - STOP - ENDIF - + + READ (30, IOSTAT=IOS) NCORE, NBLOCK, KMAXF + IERROR = IERROR + ABS(IOS) + IF (NBLOCK>NBLKIN .OR. NBLOCK<1) THEN + WRITE (ISTDE, *) 'setmcp: nblock = ', NBLOCK + STOP + ENDIF + !cjb allocate ncfblk(0:*) !cjb CALL ALLOC (NCFBLK, NBLOCK + 1, 'NCFBLK', 'SETMCP') CALL ALLOC (NCFBLK, 0, NBLOCK , 'NCFBLK', 'SETMCP') !cjb - NCFBLK(0) = 0 - - READ (30, IOSTAT=IOS) (NCFBLK(I),I=1,NBLOCK) - IERROR = IERROR + ABS(IOS) - READ (30, IOSTAT=IOS) (IDBLK(I),I=1,NBLOCK) - IERROR = IERROR + ABS(IOS) - + NCFBLK(0) = 0 + + READ (30, IOSTAT=IOS) (NCFBLK(I),I=1,NBLOCK) + IERROR = IERROR + ABS(IOS) + READ (30, IOSTAT=IOS) (IDBLK(I),I=1,NBLOCK) + IERROR = IERROR + ABS(IOS) + ! Look for other mcp files - - FOUND = .TRUE. - DO K = 31, 32 + KMAXF - CALL CONVRT (K, CK, LCK) - FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) - INQUIRE(FILE=FILNAM, EXIST=FOUND1) - FOUND = FOUND .AND. FOUND1 - END DO - - IF (.NOT.FOUND) THEN - WRITE (ISTDE, *) 'The mcp files do not exist' - STOP - ENDIF - + + FOUND = .TRUE. + DO K = 31, 32 + KMAXF + CALL CONVRT (K, CK, LCK) + FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) + INQUIRE(FILE=FILNAM, EXIST=FOUND1) + FOUND = FOUND .AND. FOUND1 + END DO + + IF (.NOT.FOUND) THEN + WRITE (ISTDE, *) 'The mcp files do not exist' + STOP + ENDIF + ! Open the files; check file headers - - DO K = 30, 32 + KMAXF - - IF (K /= 30) THEN - CALL CONVRT (K, CK, LCK) - FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) - CALL OPENFL (K, FILNAM, 'UNFORMATTED', 'OLD', IERROR) - ENDIF - - READ (K, IOSTAT=IOS) MCPLAB, NBLOCK, MYIDD, NPROCSS - - IERROR = IERROR + ABS(IOS) - IF (MYID/=MYIDD .OR. NPROCS/=NPROCSS) THEN + + DO K = 30, 32 + KMAXF + + IF (K /= 30) THEN + CALL CONVRT (K, CK, LCK) + FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) + CALL OPENFL (K, FILNAM, 'UNFORMATTED', 'OLD', IERROR) + ENDIF + + READ (K, IOSTAT=IOS) MCPLAB, NBLOCK, MYIDD, NPROCSS + + IERROR = IERROR + ABS(IOS) + IF (MYID/=MYIDD .OR. NPROCS/=NPROCSS) THEN WRITE (ISTDE, *) 'mcp files were generated under different', & - ' processor configuration.' - STOP - ENDIF - - IF (MCPLAB /= 'MCP') THEN - WRITE (ISTDE, *) 'Not a sorted GRASP92 MCP File;' - IERROR = IERROR + 1 - ENDIF - - READ (K, IOSTAT=IOS) NELEC, NCF, NW - IERROR = IERROR + ABS(IOS) - READ (K, IOSTAT=IOS) DIAG, ICCUT, LFORDR - IERROR = IERROR + ABS(IOS) - - IF (IERROR == 0) CYCLE - WRITE (ISTDE, *) 'setmcp: Error accumulated , stopping...' - DO I = 30, K - CLOSE(I) - END DO - STOP - END DO - - RETURN - END SUBROUTINE SETMCP + ' processor configuration.' + STOP + ENDIF + + IF (MCPLAB /= 'MCP') THEN + WRITE (ISTDE, *) 'Not a sorted GRASP92 MCP File;' + IERROR = IERROR + 1 + ENDIF + + READ (K, IOSTAT=IOS) NELEC, NCF, NW + IERROR = IERROR + ABS(IOS) + READ (K, IOSTAT=IOS) DIAG, ICCUT, LFORDR + IERROR = IERROR + ABS(IOS) + + IF (IERROR == 0) CYCLE + WRITE (ISTDE, *) 'setmcp: Error accumulated , stopping...' + DO I = 30, K + CLOSE(I) + END DO + STOP + END DO + + RETURN + END SUBROUTINE SETMCP diff --git a/src/appl/rmcdhf90/setmcp_I.f90 b/src/appl/rmcdhf90/setmcp_I.f90 index 9843ed938..4dd886f8f 100644 --- a/src/appl/rmcdhf90/setmcp_I.f90 +++ b/src/appl/rmcdhf90/setmcp_I.f90 @@ -1,14 +1,14 @@ - MODULE setmcp_I + MODULE setmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmcp (NCORE, NBLKIN, IDBLK, FILEHEAD) - INTEGER :: NCORE - INTEGER, INTENT(IN) :: NBLKIN - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + SUBROUTINE setmcp (NCORE, NBLKIN, IDBLK, FILEHEAD) + INTEGER :: NCORE + INTEGER, INTENT(IN) :: NBLKIN + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setmix.f90 b/src/appl/rmcdhf90/setmix.f90 index f96d2cce4..60e9f45d8 100644 --- a/src/appl/rmcdhf90/setmix.f90 +++ b/src/appl/rmcdhf90/setmix.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE SETMIX(NAME) + SUBROUTINE SETMIX(NAME) ! ! Opens the .mix file on stream 25; writes a header to this file. * ! * @@ -9,13 +9,13 @@ SUBROUTINE SETMIX(NAME) ! Modified by Xinghong He Last revision: 13 Jul 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE foparm_C USE mcpa_C @@ -26,16 +26,16 @@ SUBROUTINE SETMIX(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME*(*) + CHARACTER :: NAME*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR + INTEGER :: IERR !----------------------------------------------- ! POINTER (PCCMIN,ICCMIN(1)) ! POINTER (PNTRIQ,RIQDUM) @@ -45,19 +45,19 @@ SUBROUTINE SETMIX(NAME) ! POINTER (pncfblk,ncfblk(0:*)) ! !----------------------------------------------------------------------- - CALL OPENFL (25, NAME, 'UNFORMATTED', 'NEW', IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) - STOP - ENDIF + CALL OPENFL (25, NAME, 'UNFORMATTED', 'NEW', IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) + STOP + ENDIF ! ! Write the file header ! - WRITE (25) 'G92MIX' - WRITE (25) NELEC, NCF, NW, 0, 0, NBLOCK + WRITE (25) 'G92MIX' + WRITE (25) NELEC, NCF, NW, 0, 0, NBLOCK ! ...The above record will be overidden in matrix.f ! with the final form of ! WRITE (25) NELEC, NCF, NW, nvectot, nvecsiz, nblock - - RETURN - END SUBROUTINE SETMIX + + RETURN + END SUBROUTINE SETMIX diff --git a/src/appl/rmcdhf90/setmix_I.f90 b/src/appl/rmcdhf90/setmix_I.f90 index 2d58b604e..5309bcd0a 100644 --- a/src/appl/rmcdhf90/setmix_I.f90 +++ b/src/appl/rmcdhf90/setmix_I.f90 @@ -1,10 +1,10 @@ - MODULE setmix_I + MODULE setmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmix (NAME) - CHARACTER (LEN = *), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmix (NAME) + CHARACTER (LEN = *), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setsum.f90 b/src/appl/rmcdhf90/setsum.f90 index 301553130..843b70d76 100644 --- a/src/appl/rmcdhf90/setsum.f90 +++ b/src/appl/rmcdhf90/setsum.f90 @@ -1,8 +1,8 @@ !*********************************************************************** - SUBROUTINE SETSUM(FILNAM) + SUBROUTINE SETSUM(FILNAM) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M O D U L E S @@ -11,28 +11,28 @@ SUBROUTINE SETSUM(FILNAM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: FILNAM*(*) + CHARACTER :: FILNAM*(*) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' - CHARACTER*3, PARAMETER :: STATUS = 'NEW' + CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' + CHARACTER*3, PARAMETER :: STATUS = 'NEW' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR -!----------------------------------------------- - - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error when opening ', FILNAM - STOP - ENDIF - - RETURN - END SUBROUTINE SETSUM + INTEGER :: IERR +!----------------------------------------------- + + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error when opening ', FILNAM + STOP + ENDIF + + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rmcdhf90/setsum_I.f90 b/src/appl/rmcdhf90/setsum_I.f90 index cef3ee209..601fc2019 100644 --- a/src/appl/rmcdhf90/setsum_I.f90 +++ b/src/appl/rmcdhf90/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (FILNAM) - CHARACTER (LEN = *), INTENT(IN) :: FILNAM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (FILNAM) + CHARACTER (LEN = *), INTENT(IN) :: FILNAM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setxuv.f90 b/src/appl/rmcdhf90/setxuv.f90 index 329e97303..5de54af9a 100644 --- a/src/appl/rmcdhf90/setxuv.f90 +++ b/src/appl/rmcdhf90/setxuv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETXUV(J) + SUBROUTINE SETXUV(J) ! * ! This SUBROUTINE sets up the arrays XU and XV, for use by the * ! subprograms IN and OUT. * @@ -8,13 +8,13 @@ SUBROUTINE SETXUV(J) ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE int_C @@ -24,31 +24,31 @@ SUBROUTINE SETXUV(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NM1, I - REAL(DOUBLE) :: DMHH + INTEGER :: NM1, I + REAL(DOUBLE) :: DMHH !----------------------------------------------- ! ! Define constants ! - DMHH = -H*0.5D00 + DMHH = -H*0.5D00 ! ! Set up arrays XU and XV; since XU(1), XV(1) are never used, ! set them to some arbitrary value ! - NM1 = N - 1 - XU(1) = 0.0D00 - XV(1) = 0.0D00 + NM1 = N - 1 + XU(1) = 0.0D00 + XV(1) = 0.0D00 XU(2:NM1) = DMHH*(XP(3:NM1+1)*RPOR(3:NM1+1)+XP(2:NM1)*RPOR(2:NM1)) + DP(2& - :NM1) + :NM1) XV(2:NM1) = DMHH*(XQ(3:NM1+1)*RPOR(3:NM1+1)+XQ(2:NM1)*RPOR(2:NM1)) + DQ(2& - :NM1) + :NM1) ! - XU(N) = DMHH*XP(N)*RPOR(N) + DP(N) - XV(N) = DMHH*XP(N)*RPOR(N) + DQ(N) + XU(N) = DMHH*XP(N)*RPOR(N) + DP(N) + XV(N) = DMHH*XP(N)*RPOR(N) + DQ(N) ! - RETURN - END SUBROUTINE SETXUV + RETURN + END SUBROUTINE SETXUV diff --git a/src/appl/rmcdhf90/setxuv_I.f90 b/src/appl/rmcdhf90/setxuv_I.f90 index f4de1f63c..45b398510 100644 --- a/src/appl/rmcdhf90/setxuv_I.f90 +++ b/src/appl/rmcdhf90/setxuv_I.f90 @@ -1,10 +1,10 @@ - MODULE setxuv_I + MODULE setxuv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxuv (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxuv (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setxv.f90 b/src/appl/rmcdhf90/setxv.f90 index af4557601..5c4624bec 100644 --- a/src/appl/rmcdhf90/setxv.f90 +++ b/src/appl/rmcdhf90/setxv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETXV(J) + SUBROUTINE SETXV(J) ! * ! This subprogram sets up the inhomogeneous terms for the varia- * ! tion equations. * @@ -8,13 +8,13 @@ SUBROUTINE SETXV(J) ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE int_C @@ -23,26 +23,26 @@ SUBROUTINE SETXV(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: HHC + INTEGER :: I + REAL(DOUBLE) :: HHC !----------------------------------------------- ! - HHC = 0.5D00*H/C + HHC = 0.5D00*H/C ! ! Set up arrays TF and TG ! - DO I = 1, N - XU(I) = -QF(I,J)*HHC*RP(I) - XV(I) = PF(I,J)*HHC*RP(I) - END DO + DO I = 1, N + XU(I) = -QF(I,J)*HHC*RP(I) + XV(I) = PF(I,J)*HHC*RP(I) + END DO ! - XU(:N-1) = XU(2:N) + XU(:N-1) - XV(:N-1) = XV(2:N) + XV(:N-1) + XU(:N-1) = XU(2:N) + XU(:N-1) + XV(:N-1) = XV(2:N) + XV(:N-1) ! - RETURN + RETURN ! - END SUBROUTINE SETXV + END SUBROUTINE SETXV diff --git a/src/appl/rmcdhf90/setxv_I.f90 b/src/appl/rmcdhf90/setxv_I.f90 index 1678dbf72..7014adafd 100644 --- a/src/appl/rmcdhf90/setxv_I.f90 +++ b/src/appl/rmcdhf90/setxv_I.f90 @@ -1,10 +1,10 @@ - MODULE setxv_I + MODULE setxv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxv (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxv (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/setxz.f90 b/src/appl/rmcdhf90/setxz.f90 index b3946e541..40826c52f 100644 --- a/src/appl/rmcdhf90/setxz.f90 +++ b/src/appl/rmcdhf90/setxz.f90 @@ -1,30 +1,30 @@ !*********************************************************************** ! * - SUBROUTINE SETXZ(J) + SUBROUTINE SETXZ(J) ! * ! This subprogram sets the inhomogeneous terms to zero. * ! * ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE int_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! - XU(:N) = 0.0D00 - XV(:N) = 0.0D00 + XU(:N) = 0.0D00 + XV(:N) = 0.0D00 ! - RETURN - END SUBROUTINE SETXZ + RETURN + END SUBROUTINE SETXZ diff --git a/src/appl/rmcdhf90/setxz_I.f90 b/src/appl/rmcdhf90/setxz_I.f90 index 51304a838..ac0ae9e34 100644 --- a/src/appl/rmcdhf90/setxz_I.f90 +++ b/src/appl/rmcdhf90/setxz_I.f90 @@ -1,10 +1,10 @@ - MODULE setxz_I + MODULE setxz_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxz (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxz (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/solve.f90 b/src/appl/rmcdhf90/solve.f90 index 9a0be0225..3f35a7c89 100644 --- a/src/appl/rmcdhf90/solve.f90 +++ b/src/appl/rmcdhf90/solve.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) + SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) ! * ! This subroutine performs step 2 in Algorithm 5.2 and 5.3 of C * ! Froese Fischer, Comput Phys Rep 3 (1986) 295. Some minor changes * @@ -20,13 +20,13 @@ SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) ! Written by Farid A Parpia, at Oxford Last update: 26 Sep 1993 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE debug_C USE def_C, ONLY: C, NSOLV @@ -41,317 +41,317 @@ SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE estim_I - USE eigen_I - USE dcbsrw_I - USE setpot_I - USE setxz_I - USE start_I - USE out_I - USE in_I - USE setxuv_I - USE quad_I - USE setxv_I - USE prwf_I - USE count_I - USE newe_I + USE estim_I + USE eigen_I + USE dcbsrw_I + USE setpot_I + USE setxz_I + USE start_I + USE out_I + USE in_I + USE setxuv_I + USE quad_I + USE setxv_I + USE prwf_I + USE count_I + USE newe_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: INV - INTEGER :: JP - INTEGER :: NNP - LOGICAL :: FAIL + INTEGER :: J + INTEGER :: INV + INTEGER :: JP + INTEGER :: NNP + LOGICAL :: FAIL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KOUNT, NAKJ, NLOOPS, ICASE, MTPH, MTPI, I, MTPC, MTPV, MTPVC, & - LOC1, LOC2, LOC, MX, NPRIME - REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH, PV, QV + LOC1, LOC2, LOC, MX, NPRIME + REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH, PV, QV REAL(DOUBLE) :: TWOCSQ, ELAST, TENEJ, DELEPS, SGN, QJPOH, QJPIH, QJPOI, & QJPII, DNORM, ALFA, P0H, P0V, Q0V, QJPOV, QJPIV, CRNORM, DVNORM, AA, & BB, CC, DISCR, QQ, ROOT1, ROOT2, PMX, APM, PATI, ABPI, RATIO, TEST1, & - TEST2, DELE - LOGICAL :: CHECK + TEST2, DELE + LOGICAL :: CHECK !----------------------------------------------- ! ! Initialization ! - CHECK = .NOT.NOINVT(J) - FAIL = .FALSE. - KOUNT = 0 - NAKJ = NAK(J) + CHECK = .NOT.NOINVT(J) + FAIL = .FALSE. + KOUNT = 0 + NAKJ = NAK(J) ! TWOCSQ = 2.0D 00*137.036**2 - TWOCSQ = 2.0D00*C*C + TWOCSQ = 2.0D00*C*C ! ! Debug header ! - IF (LDBPR(22)) WRITE (99, 300) NP(J), NH(J) + IF (LDBPR(22)) WRITE (99, 300) NP(J), NH(J) ! - NLOOPS = MAX(NSOLV,3*NP(J)) + NLOOPS = MAX(NSOLV,3*NP(J)) ! - CALL ESTIM (J) - ELAST = E(J) - E(J) = EIGEN(J) + CALL ESTIM (J) + ELAST = E(J) + E(J) = EIGEN(J) ! ! Checks on lower bounds ! - IF (E(J) < EPSMIN) THEN - IF (E(J) > 0.0D00) THEN - EPSMIN = E(J) - ELSE - WRITE (*, 301) NP(J), NH(J), E(J) - E(J) = EPSMIN - IF (ABS(EMIN - ELAST)<=1.0D-06 .AND. METHOD(J)<=2) THEN - CALL DCBSRW (NP(J), NAKJ, ZINF, E(J), P0, P, Q, MTP0) - WRITE (*, 302) NP(J), NH(J), ZINF - RETURN - ENDIF - ENDIF - ENDIF + IF (E(J) < EPSMIN) THEN + IF (E(J) > 0.0D00) THEN + EPSMIN = E(J) + ELSE + WRITE (*, 301) NP(J), NH(J), E(J) + E(J) = EPSMIN + IF (ABS(EMIN - ELAST)<=1.0D-06 .AND. METHOD(J)<=2) THEN + CALL DCBSRW (NP(J), NAKJ, ZINF, E(J), P0, P, Q, MTP0) + WRITE (*, 302) NP(J), NH(J), ZINF + RETURN + ENDIF + ENDIF + ENDIF ! ! Check on upper bound ! - IF (METHOD(J) <= 2) THEN - IF (E(J) > EPSMAX) THEN - TENEJ = 10.0D00*E(J) - EPSMAX = MIN(TENEJ,TWOCSQ) - EMAX = EPSMAX - IF (E(J) > TWOCSQ) THEN - WRITE (*, 303) NP(J), NH(J), E(J) - E(J) = TWOCSQ - ENDIF - ENDIF - ENDIF + IF (METHOD(J) <= 2) THEN + IF (E(J) > EPSMAX) THEN + TENEJ = 10.0D00*E(J) + EPSMAX = MIN(TENEJ,TWOCSQ) + EMAX = EPSMAX + IF (E(J) > TWOCSQ) THEN + WRITE (*, 303) NP(J), NH(J), E(J) + E(J) = TWOCSQ + ENDIF + ENDIF + ENDIF ! ! Iteration loop begins here ! - 1 CONTINUE - KOUNT = KOUNT + 1 + 1 CONTINUE + KOUNT = KOUNT + 1 ! - P0 = PZ(J) + P0 = PZ(J) ! - IF (KOUNT > 1) THEN + IF (KOUNT > 1) THEN ! ! Check that bounds are ordered correctly ! IF (EPSMAX <= EPSMIN) WRITE (*, 304) EPSMIN, EPSMAX, NP(J), NH(J), E(J& - ) + ) ! - IF (KOUNT>NLOOPS .OR. EPSMAX-EPSMIN<1.0D00/DBLE(NP(J))**3) THEN - WRITE (*, 305) METHOD(J), NP(J), NH(J) + IF (KOUNT>NLOOPS .OR. EPSMAX-EPSMIN<1.0D00/DBLE(NP(J))**3) THEN + WRITE (*, 305) METHOD(J), NP(J), NH(J) WRITE (*, 306) KOUNT - 1, NLOOPS, P0, E(J), DELEPS, EPSMIN, EPSMAX& - , JP, MTP, NNP, NNODEP(J), SGN - FAIL = .TRUE. - RETURN - ENDIF - ENDIF + , JP, MTP, NNP, NNODEP(J), SGN + FAIL = .TRUE. + RETURN + ENDIF + ENDIF ! ! Set up arrays TF and TG; find join point ! - CALL SETPOT (J, JP) + CALL SETPOT (J, JP) ! ! Set right-hand side to zero to form homogeneous equations; ! integrate homogeneous equations outwards and inwards; store ! small component at join point each time ! - CALL SETXZ (J) - ICASE = 1 - CALL START (J, ICASE, P0, PH, Q0, QH) - CALL OUT (J, JP, PH, QH) - QJPOH = QH(JP) - CALL IN (J, JP, PH, QH, MTPH) - QJPIH = QH(JP) + CALL SETXZ (J) + ICASE = 1 + CALL START (J, ICASE, P0, PH, Q0, QH) + CALL OUT (J, JP, PH, QH) + QJPOH = QH(JP) + CALL IN (J, JP, PH, QH, MTPH) + QJPIH = QH(JP) ! ! Set up right-hand side for inhomogeneous equations; integrate ! inhomogeneous equations outwards and inwards; store small ! component at join point each time ! - CALL SETXUV (J) - ICASE = 2 - CALL START (J, ICASE, P0, P, Q0, Q) - CALL OUT (J, JP, P, Q) - QJPOI = Q(JP) - CALL IN (J, JP, P, Q, MTPI) - QJPII = Q(JP) + CALL SETXUV (J) + ICASE = 2 + CALL START (J, ICASE, P0, P, Q0, Q) + CALL OUT (J, JP, P, Q) + QJPOI = Q(JP) + CALL IN (J, JP, P, Q, MTPI) + QJPII = Q(JP) ! ! Determine energy adjustment for methods 1 and 2 ! - IF (METHOD(J) <= 2) THEN - TA(1) = 0.0D00 - TA(2:MTPI) = (P(2:MTPI)**2+Q(2:MTPI)**2)*RP(2:MTPI) - MTP = MTPI - CALL QUAD (DNORM) + IF (METHOD(J) <= 2) THEN + TA(1) = 0.0D00 + TA(2:MTPI) = (P(2:MTPI)**2+Q(2:MTPI)**2)*RP(2:MTPI) + MTP = MTPI + CALL QUAD (DNORM) ! DELEPS = 137.036*P(JP)*(QJPII-QJPOI)/DNORM - DELEPS = C*P(JP)*(QJPII - QJPOI)/DNORM - ENDIF + DELEPS = C*P(JP)*(QJPII - QJPOI)/DNORM + ENDIF ! ! Generate the continuous solution ! - MTPC = MAX(MTPH,MTPI) - ALFA = -(QJPII - QJPOI)/(QJPIH - QJPOH) - P0H = P0 - P0 = P0*(1.0D00 + ALFA) - P(:MTPC) = P(:MTPC) + ALFA*PH(:MTPC) - Q(:MTPC) = Q(:MTPC) + ALFA*QH(:MTPC) + MTPC = MAX(MTPH,MTPI) + ALFA = -(QJPII - QJPOI)/(QJPIH - QJPOH) + P0H = P0 + P0 = P0*(1.0D00 + ALFA) + P(:MTPC) = P(:MTPC) + ALFA*PH(:MTPC) + Q(:MTPC) = Q(:MTPC) + ALFA*QH(:MTPC) ! - IF (METHOD(J)==2 .OR. METHOD(J)==4) THEN + IF (METHOD(J)==2 .OR. METHOD(J)==4) THEN ! ! Set up right-hand side for variational equations; integrate ! variational equations outwards and inwards; store small ! component at join point each time ! - P0V = 0.0D00 - CALL SETXV (J) - ICASE = 3 - CALL START (J, ICASE, P0V, PV, Q0V, QV) - CALL OUT (J, JP, PV, QV) - QJPOV = QV(JP) - CALL IN (J, JP, PV, QV, MTPV) - QJPIV = QV(JP) + P0V = 0.0D00 + CALL SETXV (J) + ICASE = 3 + CALL START (J, ICASE, P0V, PV, Q0V, QV) + CALL OUT (J, JP, PV, QV) + QJPOV = QV(JP) + CALL IN (J, JP, PV, QV, MTPV) + QJPIV = QV(JP) ! ! Generate continuous solutions ! - MTPVC = MAX(MTPC,MTPV) - ALFA = -(QJPIV - QJPOV)/(QJPIH - QJPOH) - PV(:MTPVC) = PV(:MTPVC) + ALFA*PH(:MTPVC) - QV(:MTPVC) = QV(:MTPVC) + ALFA*QH(:MTPVC) + MTPVC = MAX(MTPC,MTPV) + ALFA = -(QJPIV - QJPOV)/(QJPIH - QJPOH) + PV(:MTPVC) = PV(:MTPVC) + ALFA*PH(:MTPVC) + QV(:MTPVC) = QV(:MTPVC) + ALFA*QH(:MTPVC) ! - TA(1) = 0.0D00 - TA(2:MTPC) = RP(2:MTPC)*(P(2:MTPC)**2+Q(2:MTPC)**2) - MTP = MTPC - CALL QUAD (DNORM) + TA(1) = 0.0D00 + TA(2:MTPC) = RP(2:MTPC)*(P(2:MTPC)**2+Q(2:MTPC)**2) + MTP = MTPC + CALL QUAD (DNORM) ! - MTP = MIN(MTPC,MTPVC) - TA(1) = 0.0D00 - TA(2:MTP) = RP(2:MTP)*(P(2:MTP)*PV(2:MTP)+Q(2:MTP)*QV(2:MTP)) - CALL QUAD (CRNORM) + MTP = MIN(MTPC,MTPVC) + TA(1) = 0.0D00 + TA(2:MTP) = RP(2:MTP)*(P(2:MTP)*PV(2:MTP)+Q(2:MTP)*QV(2:MTP)) + CALL QUAD (CRNORM) ! - TA(1) = 0.0D00 - TA(2:MTPVC) = RP(2:MTPVC)*(PV(2:MTPVC)**2+QV(2:MTPVC)**2) - MTP = MTPVC - CALL QUAD (DVNORM) + TA(1) = 0.0D00 + TA(2:MTPVC) = RP(2:MTPVC)*(PV(2:MTPVC)**2+QV(2:MTPVC)**2) + MTP = MTPVC + CALL QUAD (DVNORM) ! ! Determine deleps required to normalize new solution to ! first order: modified form of solution to a quadratic ! equation (see Press et al.) ! - AA = DVNORM - BB = CRNORM + CRNORM - CC = DNORM - 1.0D00 - DISCR = BB*BB - 4.0D00*AA*CC - IF (DISCR > 0.0D00) THEN - QQ = -0.5D00*(BB + SIGN(1.0D00,BB)*SQRT(DISCR)) - ROOT1 = CC/QQ - ROOT2 = QQ/AA - PMX = 0.0D00 - APM = 0.0D00 - DO I = 2, JP - PATI = P(I) - IF (PATI > PMX) THEN - PMX = PATI - LOC1 = I - ENDIF - ABPI = ABS(PATI) - IF (ABPI <= APM) CYCLE - APM = ABPI - LOC2 = I - END DO - IF (PMX /= 0.0D00) THEN - RATIO = APM/ABS(PMX) - IF (RATIO < 10.0D00) THEN - LOC = LOC1 - ELSE - LOC = LOC2 - ENDIF - ELSE - LOC = LOC2 - ENDIF - TEST1 = P(LOC) + ROOT1*PV(LOC) - TEST2 = P(LOC) + ROOT2*PV(LOC) - IF (TEST1>0.0D00 .AND. TEST2<0.0D00) THEN - DELE = ROOT1 - ELSE IF (TEST1<0.0D00 .AND. TEST2>0.0D00) THEN - DELE = ROOT2 - ELSE IF (TEST1>0.0D00 .AND. TEST2>0.0D00) THEN - IF (TEST1 < TEST2) THEN - DELE = ROOT1 - ELSE - DELE = ROOT2 - ENDIF - ELSE IF (TEST1<0.0D00 .AND. TEST2<0.0D00) THEN - IF (TEST1 > TEST2) THEN - DELE = ROOT1 - ELSE - DELE = ROOT2 - ENDIF - ENDIF - ELSE - DELE = -BB/(AA + AA) - ENDIF + AA = DVNORM + BB = CRNORM + CRNORM + CC = DNORM - 1.0D00 + DISCR = BB*BB - 4.0D00*AA*CC + IF (DISCR > 0.0D00) THEN + QQ = -0.5D00*(BB + SIGN(1.0D00,BB)*SQRT(DISCR)) + ROOT1 = CC/QQ + ROOT2 = QQ/AA + PMX = 0.0D00 + APM = 0.0D00 + DO I = 2, JP + PATI = P(I) + IF (PATI > PMX) THEN + PMX = PATI + LOC1 = I + ENDIF + ABPI = ABS(PATI) + IF (ABPI <= APM) CYCLE + APM = ABPI + LOC2 = I + END DO + IF (PMX /= 0.0D00) THEN + RATIO = APM/ABS(PMX) + IF (RATIO < 10.0D00) THEN + LOC = LOC1 + ELSE + LOC = LOC2 + ENDIF + ELSE + LOC = LOC2 + ENDIF + TEST1 = P(LOC) + ROOT1*PV(LOC) + TEST2 = P(LOC) + ROOT2*PV(LOC) + IF (TEST1>0.0D00 .AND. TEST2<0.0D00) THEN + DELE = ROOT1 + ELSE IF (TEST1<0.0D00 .AND. TEST2>0.0D00) THEN + DELE = ROOT2 + ELSE IF (TEST1>0.0D00 .AND. TEST2>0.0D00) THEN + IF (TEST1 < TEST2) THEN + DELE = ROOT1 + ELSE + DELE = ROOT2 + ENDIF + ELSE IF (TEST1<0.0D00 .AND. TEST2<0.0D00) THEN + IF (TEST1 > TEST2) THEN + DELE = ROOT1 + ELSE + DELE = ROOT2 + ENDIF + ENDIF + ELSE + DELE = -BB/(AA + AA) + ENDIF ! ! Generate new solution ! - MTP0 = MAX(MTPC,MTPVC) - P0 = P0 + DELE*ALFA*P0H - P(2:MTP0) = P(2:MTP0) + DELE*PV(2:MTP0) - Q(2:MTP0) = Q(2:MTP0) + DELE*QV(2:MTP0) - ELSE - MTP0 = MTPC - ENDIF + MTP0 = MAX(MTPC,MTPVC) + P0 = P0 + DELE*ALFA*P0H + P(2:MTP0) = P(2:MTP0) + DELE*PV(2:MTP0) + Q(2:MTP0) = Q(2:MTP0) + DELE*QV(2:MTP0) + ELSE + MTP0 = MTPC + ENDIF ! ! Debug printout ! - IF (LDBPR(23)) CALL PRWF (J) + IF (LDBPR(23)) CALL PRWF (J) ! ! Count nodes in large component function; determine sign at first ! oscillation, effective quantum number; note that node counting ! is never enforced on the small component ! - CALL COUNT (P, MTP0, NNP, SGN) + CALL COUNT (P, MTP0, NNP, SGN) ! ! DEBUG PRINTOUT ! IF (LDBPR(22)) WRITE (99, 306) KOUNT, NLOOPS, P0, E(J), DELEPS, EPSMIN, & - EPSMAX, JP, MTP, NNP, NNODEP(J), SGN + EPSMAX, JP, MTP, NNP, NNODEP(J), SGN ! ! Proceed according to method ! - IF (METHOD(J) > 2) THEN - IF (CHECK .AND. SGN<0.0D00) THEN - INV = 1 - P0 = -P0 - P(2:MTP0) = -P(2:MTP0) - Q(2:MTP0) = -Q(2:MTP0) - ENDIF - ELSE - MX = NNP - NNODEP(J) - NPRIME = NNP + NKL(J) + 1 - CALL NEWE (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) - IF (FAIL) GO TO 1 - ENDIF + IF (METHOD(J) > 2) THEN + IF (CHECK .AND. SGN<0.0D00) THEN + INV = 1 + P0 = -P0 + P(2:MTP0) = -P(2:MTP0) + Q(2:MTP0) = -Q(2:MTP0) + ENDIF + ELSE + MX = NNP - NNODEP(J) + NPRIME = NNP + NKL(J) + 1 + CALL NEWE (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + IF (FAIL) GO TO 1 + ENDIF ! ! Solution found ! - RETURN + RETURN ! - 300 FORMAT(/,/,' Debug printout active; orbital: ',1I2,1A2) - 301 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to EPSMIN') + 300 FORMAT(/,/,' Debug printout active; orbital: ',1I2,1A2) + 301 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to EPSMIN') 302 FORMAT(' Returned hydrogenic function for ',1I2,1A2,' with',& - ' effective charge ',F7.3) - 303 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to TWOCSQ') + ' effective charge ',F7.3) + 303 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to TWOCSQ') 304 FORMAT(' Warning: difficulty with node-counting procedure'/,& ' lower bound on energy (',1P,D11.4,') exceeds upper',' bound (',1D& - 11.4,'; E(',1I2,1A2,') = ',1D11.4) - 305 FORMAT(' Method ',1I1,' unable to solve for ',1I2,1A2,' orbital') + 11.4,'; E(',1I2,1A2,') = ',1D11.4) + 305 FORMAT(' Method ',1I1,' unable to solve for ',1I2,1A2,' orbital') 306 FORMAT(' Iteration number: ',1I2,', limit: ',1I2,/,& ' Present estimate of P0; ',1D21.14,/,' Present estimate of E(J): ',1D& 21.14,', DELEPS: ',1D21.14,/,' Lower bound on energy: ',1D21.14,& ', upper bound: ',1D21.14,/,' Join point: ',1I4,& ', Maximum tabulation point:',1I4,/,' Number of nodes counted: ',1I2,& - ', Correct number: ',1I2,/,' Sign of P at first oscillation: ',F3.0) - RETURN + ', Correct number: ',1I2,/,' Sign of P at first oscillation: ',F3.0) + RETURN ! - END SUBROUTINE SOLVE + END SUBROUTINE SOLVE diff --git a/src/appl/rmcdhf90/solve_I.f90 b/src/appl/rmcdhf90/solve_I.f90 index 65bf03b1e..c126a3ca8 100644 --- a/src/appl/rmcdhf90/solve_I.f90 +++ b/src/appl/rmcdhf90/solve_I.f90 @@ -1,14 +1,14 @@ - MODULE solve_I + MODULE solve_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE solve (J, FAIL, INV, JP, NNP) - INTEGER, INTENT(IN) :: J - LOGICAL, INTENT(OUT) :: FAIL - INTEGER, INTENT(OUT) :: INV - INTEGER, INTENT(IN) :: JP - INTEGER, INTENT(IN) :: NNP - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE solve (J, FAIL, INV, JP, NNP) + INTEGER, INTENT(IN) :: J + LOGICAL, INTENT(OUT) :: FAIL + INTEGER, INTENT(OUT) :: INV + INTEGER, INTENT(IN) :: JP + INTEGER, INTENT(IN) :: NNP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/strsum.f90 b/src/appl/rmcdhf90/strsum.f90 index e311227f8..f290a35b4 100644 --- a/src/appl/rmcdhf90/strsum.f90 +++ b/src/appl/rmcdhf90/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** - SUBROUTINE STRSUM - + SUBROUTINE STRSUM + ! Generates the first part of rscf92.sum (on stream 24). ! ! Call(s) to: [LIB92] CALEN, CONVRT. @@ -8,13 +8,13 @@ SUBROUTINE STRSUM ! Written by Farid A. Parpia Last revision: 26 Sep 1993 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE foparm_C USE grid_C @@ -28,13 +28,13 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, IEND, I, IBEG - CHARACTER :: RECORD*256, CDATA*26, CTIME*8, CDATE*8, CLEVEL*2 + INTEGER :: LENTH, IEND, I, IBEG + CHARACTER :: RECORD*256, CDATA*26, CTIME*8, CDATE*8, CLEVEL*2 !----------------------------------------------- ! ! POINTER (PWEIGH,WEIGHT(1)) @@ -45,7 +45,7 @@ SUBROUTINE STRSUM ! Both the nuclear charge and the number of electrons are ! known at this point; load IONCTY with the ionicity ! - IONCTY = NINT(Z) - NELEC + IONCTY = NINT(Z) - NELEC ! ! Get the date and time of day; make this information the ! header of the summary file @@ -55,118 +55,118 @@ SUBROUTINE STRSUM ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (LFORDR) THEN - WRITE (24, *) - CALL CONVRT (ICCUT, RECORD, LENTH) + IF (LFORDR) THEN + WRITE (24, *) + CALL CONVRT (ICCUT, RECORD, LENTH) WRITE (24, *) ' CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space;' - ENDIF + ' the zero-order space;' + ENDIF ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z + WRITE (24, *) + WRITE (24, 300) Z - IF (EMN == 0.D0) THEN - WRITE (24, *) ' the nucleus is stationary;' - ELSE - WRITE (24, 301) EMN - ENDIF - IF (NPARM == 2) THEN - WRITE (24, *) ' Fermi nucleus:' - WRITE (24, 302) PARM(1), PARM(2) - CALL CONVRT (NNUC, RECORD, LENTH) + IF (EMN == 0.D0) THEN + WRITE (24, *) ' the nucleus is stationary;' + ELSE + WRITE (24, 301) EMN + ENDIF + IF (NPARM == 2) THEN + WRITE (24, *) ' Fermi nucleus:' + WRITE (24, 302) PARM(1), PARM(2) + CALL CONVRT (NNUC, RECORD, LENTH) WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 303) C + WRITE (24, *) + WRITE (24, 303) C ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.D0) THEN - WRITE (24, 305) RNT, H, N - ELSE - WRITE (24, 306) RNT, H, HP, N - ENDIF - WRITE (24, 307) R(1), R(2), R(N) - WRITE (24, *) + WRITE (24, *) + IF (HP == 0.D0) THEN + WRITE (24, 305) RNT, H, N + ELSE + WRITE (24, 306) RNT, H, HP, N + ENDIF + WRITE (24, 307) R(1), R(2), R(N) + WRITE (24, *) ! ! (E)AL calculation, returns here ! - IF (NCMIN == 0) THEN - WRITE (24, *) '(E)AL calculation.' - RETURN - ENDIF + IF (NCMIN == 0) THEN + WRITE (24, *) '(E)AL calculation.' + RETURN + ENDIF ! ! Info exclusively for EOL calculations ! - IF (NCMIN == 1) THEN - WRITE (24, *) 'OL calculation.' - CALL CONVRT (ICCMIN(1), RECORD, LENTH) - WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be optimised.' - ELSE - WRITE (24, *) 'EOL calculation.' - CALL CONVRT (NCMIN, RECORD, LENTH) - WRITE (24, *) RECORD(1:LENTH)//' levels will be optimised;' - RECORD(1:20) = ' their indices are: ' - IEND = 20 - DO I = 1, NCMIN - IBEG = IEND + 1 - CALL CONVRT (ICCMIN(I), CLEVEL, LENTH) - IF (I /= NCMIN) THEN - IEND = IBEG + LENTH + 1 - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' - ELSE - IEND = IBEG + LENTH - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' - ENDIF - IF (IEND < 120) CYCLE - WRITE (24, *) RECORD(1:IEND) - RECORD(1:2) = ' ' - IEND = 2 - END DO - IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) - IF (WEIGHT(1) == (-1.D0)) THEN - WRITE (24, *) 'Each is assigned its statistical weight;' - ELSE IF (WEIGHT(1) == (-2.D0)) THEN - WRITE (24, *) 'All levels are weighted equally;' - ELSE - WRITE (24, *) ' weighted as follows:' - WRITE (24, *) (WEIGHT(I),I=1,NCMIN) - ENDIF - ENDIF - - 300 FORMAT('The atomic number is ',1F14.10,';') - 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') - 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 303 FORMAT('Speed of light = ',3P,D19.12,' atomic units.') + IF (NCMIN == 1) THEN + WRITE (24, *) 'OL calculation.' + CALL CONVRT (ICCMIN(1), RECORD, LENTH) + WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be optimised.' + ELSE + WRITE (24, *) 'EOL calculation.' + CALL CONVRT (NCMIN, RECORD, LENTH) + WRITE (24, *) RECORD(1:LENTH)//' levels will be optimised;' + RECORD(1:20) = ' their indices are: ' + IEND = 20 + DO I = 1, NCMIN + IBEG = IEND + 1 + CALL CONVRT (ICCMIN(I), CLEVEL, LENTH) + IF (I /= NCMIN) THEN + IEND = IBEG + LENTH + 1 + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' + ELSE + IEND = IBEG + LENTH + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' + ENDIF + IF (IEND < 120) CYCLE + WRITE (24, *) RECORD(1:IEND) + RECORD(1:2) = ' ' + IEND = 2 + END DO + IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) + IF (WEIGHT(1) == (-1.D0)) THEN + WRITE (24, *) 'Each is assigned its statistical weight;' + ELSE IF (WEIGHT(1) == (-2.D0)) THEN + WRITE (24, *) 'All levels are weighted equally;' + ELSE + WRITE (24, *) ' weighted as follows:' + WRITE (24, *) (WEIGHT(I),I=1,NCMIN) + ENDIF + ENDIF + + 300 FORMAT('The atomic number is ',1F14.10,';') + 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') + 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 303 FORMAT('Speed of light = ',3P,D19.12,' atomic units.') 305 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 306 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 307 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') - - RETURN - END SUBROUTINE STRSUM + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + + RETURN + END SUBROUTINE STRSUM diff --git a/src/appl/rmcdhf90/strsum_I.f90 b/src/appl/rmcdhf90/strsum_I.f90 index e75d8b2d0..1ec5c8f52 100644 --- a/src/appl/rmcdhf90/strsum_I.f90 +++ b/src/appl/rmcdhf90/strsum_I.f90 @@ -1,10 +1,10 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum + SUBROUTINE strsum !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/xpot.f90 b/src/appl/rmcdhf90/xpot.f90 index deeaf46b4..8495147da 100644 --- a/src/appl/rmcdhf90/xpot.f90 +++ b/src/appl/rmcdhf90/xpot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE XPOT(J) + SUBROUTINE XPOT(J) ! * ! This subroutine tabulates the exchange terms (the first terms on * ! the right-hand sides of eqs (14), I P Grant, B J McKenzie, P H * @@ -13,11 +13,11 @@ SUBROUTINE XPOT(J) ! Written by Farid A Parpia, at Oxford Last update: 10 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB @@ -32,97 +32,97 @@ SUBROUTINE XPOT(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE yzk_I - USE draw_I + USE yzk_I + USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, IORB, NB2, NROWS, II, II1, II2 - REAL(DOUBLE) :: COEFF, CTB + INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, IORB, NB2, NROWS, II, II1, II2 + REAL(DOUBLE) :: COEFF, CTB !----------------------------------------------- ! ! Debug printout: header ! - IF (LDBPR(27) .OR. LDBPR(28)) WRITE (99, 300) NP(J), NH(J) + IF (LDBPR(27) .OR. LDBPR(28)) WRITE (99, 300) NP(J), NH(J) ! ! Clear for accumulation of sums ! - XP(:N) = 0.D0 - XQ(:N) = 0.D0 + XP(:N) = 0.D0 + XQ(:N) = 0.D0 ! ! Add contributions from exchange terms ! - DO INDEX = 1, NXCOF - + DO INDEX = 1, NXCOF + ! Decode information in label - LABEL = NXA(INDEX) - K = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY1 = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY2 = MOD(LABEL,KEY) - IORB = LABEL/KEY - COEFF = XA(INDEX) - + LABEL = NXA(INDEX) + K = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY1 = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY2 = MOD(LABEL,KEY) + IORB = LABEL/KEY + COEFF = XA(INDEX) + ! Debug printout: composition IF (LDBPR(27)) WRITE (99, 301) K, COEFF, NP(IOY1), NH(IOY1), NP(IOY2)& - , NH(IOY2), NP(IORB), NH(IORB) - - CALL YZK (K, IOY1, IOY2) + , NH(IOY2), NP(IORB), NH(IORB) + + CALL YZK (K, IOY1, IOY2) ! ! Accumulate contributions ! - COEFF = COEFF/C + COEFF = COEFF/C !DO I = 1, MF(IORB) - DO I = 1, N - CTB = COEFF*TB(I) - XP(I) = XP(I) + CTB*QF(I,IORB) - XQ(I) = XQ(I) - CTB*PF(I,IORB) - END DO - END DO + DO I = 1, N + CTB = COEFF*TB(I) + XP(I) = XP(I) + CTB*QF(I,IORB) + XQ(I) = XQ(I) - CTB*PF(I,IORB) + END DO + END DO ! ! Debug printout: potential functions ! - IF (LDBPR(28)) THEN - WRITE (99, 302) - NB2 = N/2 - IF (2*NB2 == N) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= N) THEN + IF (LDBPR(28)) THEN + WRITE (99, 302) + NB2 = N/2 + IF (2*NB2 == N) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= N) THEN WRITE (99, 303) R(II1), XP(II1), XQ(II1), R(II2), XP(II2), XQ(& - II2) - ELSE IF (II1 <= N) THEN - WRITE (99, 303) R(II1), XP(II1), XQ(II1) - ENDIF - END DO - CALL DRAW (XP, 1.0D00, XQ, C, N) - ENDIF + II2) + ELSE IF (II1 <= N) THEN + WRITE (99, 303) R(II1), XP(II1), XQ(II1) + ENDIF + END DO + CALL DRAW (XP, 1.0D00, XQ, C, N) + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,/,' Exchange potential contributions (coefficients will ',& - ' be divided by C) for ',1I2,1A2,' orbital :'/,/) + ' be divided by C) for ',1I2,1A2,' orbital :'/,/) 301 FORMAT(/,25X,'(',1I2,')'/,1X,1P,D21.14,'* Y (',1I2,1A2,',',1I2,1A2,& - ') ','* P (',1I2,1A2,')') + ') ','* P (',1I2,1A2,')') 302 FORMAT(/,/,31X,'(P)',19X,'(Q)',41X,'(P)',19X,'(Q)'/,2(& ' --------- r --------- ------ X (r) -------',& - ' ------ X (r) -------')) - 303 FORMAT(1P,6(1X,1D21.14)) - RETURN + ' ------ X (r) -------')) + 303 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE XPOT + END SUBROUTINE XPOT diff --git a/src/appl/rmcdhf90/xpot_I.f90 b/src/appl/rmcdhf90/xpot_I.f90 index f999e432f..582029e32 100644 --- a/src/appl/rmcdhf90/xpot_I.f90 +++ b/src/appl/rmcdhf90/xpot_I.f90 @@ -1,11 +1,11 @@ - MODULE xpot_I + MODULE xpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE xpot (J) - INTEGER, INTENT(IN) :: J + SUBROUTINE xpot (J) + INTEGER, INTENT(IN) :: J !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90/ypot.f90 b/src/appl/rmcdhf90/ypot.f90 index 83bb8aa92..fcf76eb4d 100644 --- a/src/appl/rmcdhf90/ypot.f90 +++ b/src/appl/rmcdhf90/ypot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE YPOT(J) + SUBROUTINE YPOT(J) ! * ! This subroutine tabulates the potential function Y(r) (Eq (14) * ! in I P Grant, B J McKenzie, P H Norrington, D F Mayers, and N C * @@ -13,11 +13,11 @@ SUBROUTINE YPOT(J) ! MPI version by Xinghong He Last revision: 05 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB @@ -31,84 +31,84 @@ SUBROUTINE YPOT(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE yzk_I - USE draw_I + USE yzk_I + USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, NB3, NROWS, II, II1, II2, II3 - REAL(DOUBLE) :: COEFF + INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, NB3, NROWS, II, II1, II2, II3 + REAL(DOUBLE) :: COEFF !----------------------------------------------- ! Debug printout: composition - - IF (LDBPR(29) .OR. LDBPR(30)) WRITE (99, 300) NP(J), NH(J) + + IF (LDBPR(29) .OR. LDBPR(30)) WRITE (99, 300) NP(J), NH(J) ! ! Initialize array YP with the nuclear potential piece ! ! Since YA() below contains contributions from THIS node only, ! the initialization should be in consistence with that. - + YP(:N) = ZZ(:N) - - DO INDEX = 1, NYCOF - + + DO INDEX = 1, NYCOF + ! Decode information in label - LABEL = NYA(INDEX) - K = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY1 = MOD(LABEL,KEY) - IOY2 = LABEL/KEY - COEFF = YA(INDEX) - + LABEL = NYA(INDEX) + K = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY1 = MOD(LABEL,KEY) + IOY2 = LABEL/KEY + COEFF = YA(INDEX) + IF (LDBPR(29)) WRITE (99, 301) K, COEFF, NP(IOY1), NH(IOY1), NP(IOY2)& - , NH(IOY2) - - CALL YZK (K, IOY1, IOY2) ! Accumulate contributions - YP(:N) = YP(:N) - COEFF*TB(:N) - END DO + , NH(IOY2) + + CALL YZK (K, IOY1, IOY2) ! Accumulate contributions + YP(:N) = YP(:N) - COEFF*TB(:N) + END DO ! ! Debug printout ! - IF (LDBPR(30)) THEN - WRITE (99, 302) - NB3 = N/3 - IF (3*NB3 == N) THEN - NROWS = NB3 - ELSE - NROWS = NB3 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - II3 = II2 + NROWS - IF (II3 <= N) THEN + IF (LDBPR(30)) THEN + WRITE (99, 302) + NB3 = N/3 + IF (3*NB3 == N) THEN + NROWS = NB3 + ELSE + NROWS = NB3 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + II3 = II2 + NROWS + IF (II3 <= N) THEN WRITE (99, 303) R(II1), YP(II1), R(II2), YP(II2), R(II3), YP(II3& - ) - ELSE IF (II2 <= N) THEN - WRITE (99, 303) R(II1), YP(II1), R(II2), YP(II2) - ELSE - WRITE (99, 303) R(II1), YP(II1) - ENDIF - END DO - CALL DRAW (YP, 1.0D00, YP, 0.0D00, N) - ENDIF + ) + ELSE IF (II2 <= N) THEN + WRITE (99, 303) R(II1), YP(II1), R(II2), YP(II2) + ELSE + WRITE (99, 303) R(II1), YP(II1) + ENDIF + END DO + CALL DRAW (YP, 1.0D00, YP, 0.0D00, N) + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,/,' Direct potential for ',1I2,1A2,' orbital :'/,/) + 300 FORMAT(/,/,' Direct potential for ',1I2,1A2,' orbital :'/,/) 301 FORMAT(/,25X,'(',1I2,')'/,1X,1P,D21.14,'* Y (',1I2,1A2,',',1I2,1A2,')'& - ) - 302 FORMAT(/,/,3(' --------- r --------- ------- Y (r) -------')) - 303 FORMAT(1P,6(1X,1D21.14)) - RETURN + ) + 302 FORMAT(/,/,3(' --------- r --------- ------- Y (r) -------')) + 303 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE YPOT + END SUBROUTINE YPOT diff --git a/src/appl/rmcdhf90/ypot_I.f90 b/src/appl/rmcdhf90/ypot_I.f90 index ae9337fc4..dd9535fca 100644 --- a/src/appl/rmcdhf90/ypot_I.f90 +++ b/src/appl/rmcdhf90/ypot_I.f90 @@ -1,10 +1,10 @@ - MODULE ypot_I + MODULE ypot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ypot (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ypot (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/Makefile b/src/appl/rmcdhf90_mpi/Makefile old mode 100755 new mode 100644 index 5b65b49ae..2e168cd6e --- a/src/appl/rmcdhf90_mpi/Makefile +++ b/src/appl/rmcdhf90_mpi/Makefile @@ -45,7 +45,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLMPIU90) -I ${MODDVD} \ @@ -55,5 +55,4 @@ $(EXE): $(APP_OBJ) $(FC) -c $(FC_FLAGS) $< -o $@ clean: - -rm -f *.o *.mod core - + -rm -f *.o *.mod core diff --git a/src/appl/rmcdhf90_mpi/cofpotmpi.f90 b/src/appl/rmcdhf90_mpi/cofpotmpi.f90 index b0be68929..7d925bac4 100644 --- a/src/appl/rmcdhf90_mpi/cofpotmpi.f90 +++ b/src/appl/rmcdhf90_mpi/cofpotmpi.f90 @@ -1,38 +1,38 @@ - SUBROUTINE COFPOTmpi(EOL, J, NPTS) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer + SUBROUTINE COFPOTmpi(EOL, J, NPTS) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE pote_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcof_I - USE ypot_I - USE xpot_I - USE lagcon_I - USE dacon_I + USE setcof_I + USE ypot_I + USE xpot_I + USE lagcon_I + USE dacon_I USE POTE_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: NPTS - LOGICAL :: EOL + INTEGER :: J + INTEGER :: NPTS + LOGICAL :: EOL REAL(DOUBLE), DIMENSION(NPTS) :: TMPMPI !----------------------------------------------------------------------- - CALL SETCOF (EOL, J) - CALL YPOT (J) - CALL XPOT (J) - CALL LAGCON (J, NPROCS) - CALL DACON + CALL SETCOF (EOL, J) + CALL YPOT (J) + CALL XPOT (J) + CALL LAGCON (J, NPROCS) + CALL DACON CALL MPI_Allreduce (YP, tmpmpi, npts, MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) @@ -45,6 +45,6 @@ SUBROUTINE COFPOTmpi(EOL, J, NPTS) CALL MPI_Allreduce (XQ, tmpmpi, npts, MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) CALL dcopy (npts, tmpmpi, 1, XQ, 1) - - RETURN + + RETURN END SUBROUTINE COFPOTmpi diff --git a/src/appl/rmcdhf90_mpi/cofpotmpi_I.f90 b/src/appl/rmcdhf90_mpi/cofpotmpi_I.f90 index d09d62fe5..dfac9456e 100644 --- a/src/appl/rmcdhf90_mpi/cofpotmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/cofpotmpi_I.f90 @@ -1,12 +1,12 @@ - MODULE cofpotmpi_I + MODULE cofpotmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cofpotmpi (EOL, J, NPTS) - LOGICAL :: EOL - INTEGER :: J - INTEGER :: NPTS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cofpotmpi (EOL, J, NPTS) + LOGICAL :: EOL + INTEGER :: J + INTEGER :: NPTS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/consis.f90 b/src/appl/rmcdhf90_mpi/consis.f90 index e8b26d4df..b5bbe52bc 100644 --- a/src/appl/rmcdhf90_mpi/consis.f90 +++ b/src/appl/rmcdhf90_mpi/consis.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE CONSIS(J) + SUBROUTINE CONSIS(J) ! * ! This routine computes the weighted self-consistency of orbital J * ! * ! Written by Farid A Parpia, at OXFORD Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE int_C USE scf_C @@ -22,22 +22,22 @@ SUBROUTINE CONSIS(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTP, I - REAL(DOUBLE) :: SCMEA, DELTAO + INTEGER :: MTP, I + REAL(DOUBLE) :: SCMEA, DELTAO !----------------------------------------------- ! ! - SCMEA = 0.0D00 - MTP = MIN(MTP0,MF(J)) - DO I = 1, MTP - DELTAO = ABS(P(I)-PF(I,J)) + ABS(Q(I)-QF(I,J)) - SCMEA = DMAX1(DELTAO,SCMEA) - END DO - SCNSTY(J) = SCMEA*SQRT(UCF(J)) + SCMEA = 0.0D00 + MTP = MIN(MTP0,MF(J)) + DO I = 1, MTP + DELTAO = ABS(P(I)-PF(I,J)) + ABS(Q(I)-QF(I,J)) + SCMEA = DMAX1(DELTAO,SCMEA) + END DO + SCNSTY(J) = SCMEA*SQRT(UCF(J)) ! - RETURN - END SUBROUTINE CONSIS + RETURN + END SUBROUTINE CONSIS diff --git a/src/appl/rmcdhf90_mpi/consis_I.f90 b/src/appl/rmcdhf90_mpi/consis_I.f90 index a21d55ce0..f25585730 100644 --- a/src/appl/rmcdhf90_mpi/consis_I.f90 +++ b/src/appl/rmcdhf90_mpi/consis_I.f90 @@ -1,10 +1,10 @@ - MODULE consis_I + MODULE consis_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE consis (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE consis (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/csfwgt.f90 b/src/appl/rmcdhf90_mpi/csfwgt.f90 index f6e04b09f..20cf49cbb 100644 --- a/src/appl/rmcdhf90_mpi/csfwgt.f90 +++ b/src/appl/rmcdhf90_mpi/csfwgt.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE CSFWGT(LSTDIO) + SUBROUTINE CSFWGT(LSTDIO) ! * ! Print the weights of the largest five CSF contributors to each * ! ASF. * @@ -13,13 +13,13 @@ SUBROUTINE CSFWGT(LSTDIO) ! JCUPA(NNNWP*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE jlabl_C, LABJ=>JLBR, LABP=>JLBP @@ -32,36 +32,36 @@ SUBROUTINE CSFWGT(LSTDIO) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(IN) :: LSTDIO + LOGICAL, INTENT(IN) :: LSTDIO !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(5) :: ICONF + INTEGER, DIMENSION(5) :: ICONF INTEGER :: IV, JBLOCK, NCF, NCFPAT, NCMINPAT, NEVECPAT, NEVECOFF, NELT, & - ICF, IVTJPO, IVSPAR, I, J, ITEMP, IREM, IP + ICF, IVTJPO, IVSPAR, I, J, ITEMP, IREM, IP REAL(DOUBLE) :: TEMP, W REAL(DOUBLE), DIMENSION(5) :: COEFF - CHARACTER :: RECORD*256, CNUM*8 + CHARACTER :: RECORD*256, CNUM*8 !----------------------------------------------- ! - - IF (LSTDIO) THEN - WRITE (ISTDO, 300) - ELSE - WRITE (24, 300) - ENDIF - - DO IV = 1, NCMIN + + IF (LSTDIO) THEN + WRITE (ISTDO, 300) + ELSE + WRITE (24, 300) + ENDIF + + DO IV = 1, NCMIN ! loop over eigenvectors - - JBLOCK = IDXBLK(IV) - NCF = NCFBLK(JBLOCK) - NCFPAT = NCFPAST(JBLOCK) - NCMINPAT = NCMINPAST(JBLOCK) - NEVECPAT = NEVECPAST(JBLOCK) - NEVECOFF = NEVECPAT + (IV - NCMINPAT - 1)*NCF - NELT = MIN(5,NCF) !Find maximum 5 ... within block - ICF = ICCMIN(IV) + + JBLOCK = IDXBLK(IV) + NCF = NCFBLK(JBLOCK) + NCFPAT = NCFPAST(JBLOCK) + NCMINPAT = NCMINPAST(JBLOCK) + NEVECPAT = NEVECPAST(JBLOCK) + NEVECOFF = NEVECPAT + (IV - NCMINPAT - 1)*NCF + NELT = MIN(5,NCF) !Find maximum 5 ... within block + ICF = ICCMIN(IV) !GGGG ivtjpo = IABS(JPGG(jblock)) IF(JPGG(jblock) .GE. 0) THEN @@ -69,62 +69,62 @@ SUBROUTINE CSFWGT(LSTDIO) ELSE ivspar = 1 END IF -!GG IVTJPO = IATJPO(IV) ! j-value related -!GG IVSPAR = IASPAR(IV) ! parity related - - - DO I = 1, NELT - COEFF(I) = EVEC(NEVECOFF + I) - ICONF(I) = I - END DO - +!GG IVTJPO = IATJPO(IV) ! j-value related +!GG IVSPAR = IASPAR(IV) ! parity related + + + DO I = 1, NELT + COEFF(I) = EVEC(NEVECOFF + I) + ICONF(I) = I + END DO + ! sort the first nelt in decreasing order - DO I = 1, NELT - DO J = I + 1, NELT - IF (ABS(COEFF(J)) <= ABS(COEFF(I))) CYCLE - TEMP = COEFF(I) - COEFF(I) = COEFF(J) - COEFF(J) = TEMP - ITEMP = ICONF(I) - ICONF(I) = ICONF(J) - ICONF(J) = ITEMP - END DO - END DO - - L20: DO I = NELT + 1, NCF - W = EVEC(NEVECOFF + I) - IF (W==0.D0 .OR. ABS(W)<=ABS(COEFF(NELT))) CYCLE L20 + DO I = 1, NELT + DO J = I + 1, NELT + IF (ABS(COEFF(J)) <= ABS(COEFF(I))) CYCLE + TEMP = COEFF(I) + COEFF(I) = COEFF(J) + COEFF(J) = TEMP + ITEMP = ICONF(I) + ICONF(I) = ICONF(J) + ICONF(J) = ITEMP + END DO + END DO + + L20: DO I = NELT + 1, NCF + W = EVEC(NEVECOFF + I) + IF (W==0.D0 .OR. ABS(W)<=ABS(COEFF(NELT))) CYCLE L20 ! we have a non-zero value larger than the largest so far - DO J = 1, NELT - IF (ABS(W) <= ABS(COEFF(J))) CYCLE - COEFF(NELT:1+J:(-1)) = COEFF(NELT-1:J:(-1)) - ICONF(NELT:1+J:(-1)) = ICONF(NELT-1:J:(-1)) - COEFF(J) = W - ICONF(J) = I - CYCLE L20 - END DO - END DO L20 - -!GG IP = (IASPAR(IV) + 3)/2 + DO J = 1, NELT + IF (ABS(W) <= ABS(COEFF(J))) CYCLE + COEFF(NELT:1+J:(-1)) = COEFF(NELT-1:J:(-1)) + ICONF(NELT:1+J:(-1)) = ICONF(NELT-1:J:(-1)) + COEFF(J) = W + ICONF(J) = I + CYCLE L20 + END DO + END DO L20 + +!GG IP = (IASPAR(IV) + 3)/2 ip = ivspar - - IF (LSTDIO) THEN + + IF (LSTDIO) THEN WRITE (ISTDO, 320) JBLOCK, ICF, LABJ(IVTJPO), LABP(IP), (COEFF(I),I& - =1,NELT) - WRITE (ISTDO, 330) (ICONF(I),I=1,NELT) - ELSE - + =1,NELT) + WRITE (ISTDO, 330) (ICONF(I),I=1,NELT) + ELSE + WRITE (24, 320) JBLOCK, ICF, LABJ(IVTJPO), LABP(IP), (COEFF(I),I=1,& - NELT) - WRITE (24, 330) (ICONF(I),I=1,NELT) - ENDIF - END DO - + NELT) + WRITE (24, 330) (ICONF(I),I=1,NELT) + ENDIF + END DO + 300 FORMAT(/,'Weights of major contributors to ASF:'/,/,& - 'Block Level J Parity CSF contributions'/) - 310 FORMAT(1X,A14,80A) - 320 FORMAT(I3,1X,I5,2X,2A4,5(3X,F8.4)) - 330 FORMAT(19X,5(3X,I8)) - - RETURN - END SUBROUTINE CSFWGT + 'Block Level J Parity CSF contributions'/) + 310 FORMAT(1X,A14,80A) + 320 FORMAT(I3,1X,I5,2X,2A4,5(3X,F8.4)) + 330 FORMAT(19X,5(3X,I8)) + + RETURN + END SUBROUTINE CSFWGT diff --git a/src/appl/rmcdhf90_mpi/csfwgt_I.f90 b/src/appl/rmcdhf90_mpi/csfwgt_I.f90 index 4104ccc06..3058257cf 100644 --- a/src/appl/rmcdhf90_mpi/csfwgt_I.f90 +++ b/src/appl/rmcdhf90_mpi/csfwgt_I.f90 @@ -1,10 +1,10 @@ - MODULE csfwgt_I + MODULE csfwgt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE csfwgt (LSTDIO) - LOGICAL, INTENT(IN) :: LSTDIO - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE csfwgt (LSTDIO) + LOGICAL, INTENT(IN) :: LSTDIO + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/dacon.f90 b/src/appl/rmcdhf90_mpi/dacon.f90 index e2594282c..2da3f9e8d 100644 --- a/src/appl/rmcdhf90_mpi/dacon.f90 +++ b/src/appl/rmcdhf90_mpi/dacon.f90 @@ -1,7 +1,7 @@ - + !*********************************************************************** ! * - SUBROUTINE DACON + SUBROUTINE DACON ! * ! This routine includes the contribution from the off-diagonal * ! I(a,b) integrals in the 'exchange' term. * @@ -11,13 +11,13 @@ SUBROUTINE DACON ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE npot_C @@ -30,31 +30,31 @@ SUBROUTINE DACON !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IORB, MFI, I - REAL(DOUBLE) :: TWOC, COEFF, FK, RPORII, PFI, QFI, ZBCI + INTEGER :: K, IORB, MFI, I + REAL(DOUBLE) :: TWOC, COEFF, FK, RPORII, PFI, QFI, ZBCI !----------------------------------------------- ! ! - TWOC = C + C + TWOC = C + C ! - DO K = 1, NDCOF + DO K = 1, NDCOF ! - IORB = NDA(K) - CALL DPBDT (IORB) - MFI = MF(IORB) - COEFF = DA(K) - FK = DBLE(NAK(IORB)) + IORB = NDA(K) + CALL DPBDT (IORB) + MFI = MF(IORB) + COEFF = DA(K) + FK = DBLE(NAK(IORB)) ! - DO I = 2, MFI - RPORII = 1.0D0/(H*RPOR(I)) - PFI = PF(I,IORB) - QFI = QF(I,IORB) - ZBCI = ZZ(I)/C - XP(I) = XP(I) + COEFF*(TA(I)*RPORII+FK*PFI-(TWOC*R(I)+ZBCI)*QFI) - XQ(I) = XQ(I) + COEFF*(TB(I)*RPORII-FK*QFI+ZBCI*PFI) - END DO + DO I = 2, MFI + RPORII = 1.0D0/(H*RPOR(I)) + PFI = PF(I,IORB) + QFI = QF(I,IORB) + ZBCI = ZZ(I)/C + XP(I) = XP(I) + COEFF*(TA(I)*RPORII+FK*PFI-(TWOC*R(I)+ZBCI)*QFI) + XQ(I) = XQ(I) + COEFF*(TB(I)*RPORII-FK*QFI+ZBCI*PFI) + END DO ! - END DO + END DO ! - RETURN - END SUBROUTINE DACON + RETURN + END SUBROUTINE DACON diff --git a/src/appl/rmcdhf90_mpi/dacon_I.f90 b/src/appl/rmcdhf90_mpi/dacon_I.f90 index d2374027a..f908ea6eb 100644 --- a/src/appl/rmcdhf90_mpi/dacon_I.f90 +++ b/src/appl/rmcdhf90_mpi/dacon_I.f90 @@ -1,9 +1,9 @@ - MODULE dacon_I + MODULE dacon_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dacon - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dacon + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/dampck.f90 b/src/appl/rmcdhf90_mpi/dampck.f90 index aeb107776..abde32f81 100644 --- a/src/appl/rmcdhf90_mpi/dampck.f90 +++ b/src/appl/rmcdhf90_mpi/dampck.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DAMPCK(IPR, J, ED1, ED2) + SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ! * ! This subroutine determines the damping factor appropriate to the * ! present orbital. The algorithm is taken from C Froese Fischer's * @@ -10,33 +10,33 @@ SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ! Modified by C. Froese Fischer Last update: 07 Apr 2009 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE damp_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IPR - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(INOUT) :: ED1 - REAL(DOUBLE), INTENT(INOUT) :: ED2 + INTEGER, INTENT(INOUT) :: IPR + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(INOUT) :: ED1 + REAL(DOUBLE), INTENT(INOUT) :: ED2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: ADAPTV + LOGICAL :: ADAPTV !----------------------------------------------- ! ! The damping is adaptive (i.e., can be modified by this SUBROUTINE) ! if and only if ODAMP(J) .GE. 0.0 ! - ADAPTV = ODAMP(J) >= 0.0D00 + ADAPTV = ODAMP(J) >= 0.0D00 ! IF (IPR /= J) THEN IF (ADAPTV) ODAMP(J) = 0.75D00*ODAMP(J) @@ -58,5 +58,5 @@ SUBROUTINE DAMPCK(IPR, J, ED1, ED2) ENDIF ! IPR = J - RETURN - END SUBROUTINE DAMPCK + RETURN + END SUBROUTINE DAMPCK diff --git a/src/appl/rmcdhf90_mpi/dampck_I.f90 b/src/appl/rmcdhf90_mpi/dampck_I.f90 index bd0aee119..527ab298a 100644 --- a/src/appl/rmcdhf90_mpi/dampck_I.f90 +++ b/src/appl/rmcdhf90_mpi/dampck_I.f90 @@ -1,14 +1,14 @@ - MODULE dampck_I + MODULE dampck_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dampck (IPR, J, ED1, ED2) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(INOUT) :: IPR - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(INOUT) :: ED1 - REAL(DOUBLE), INTENT(INOUT) :: ED2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dampck (IPR, J, ED1, ED2) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(INOUT) :: IPR + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(INOUT) :: ED1 + REAL(DOUBLE), INTENT(INOUT) :: ED2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/dampor.f90 b/src/appl/rmcdhf90_mpi/dampor.f90 index 49de726f4..a4f301ff5 100644 --- a/src/appl/rmcdhf90_mpi/dampor.f90 +++ b/src/appl/rmcdhf90_mpi/dampor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DAMPOR(J, INV, ODAMPJ) + SUBROUTINE DAMPOR(J, INV, ODAMPJ) ! * ! This subroutine damps the orbital wave function with index J. it * ! also stores the previous determination of this orbital. * @@ -10,13 +10,13 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) ! Written by Farid A Parpia, at Oxford Last update: 22 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE damp_C USE def_C @@ -29,29 +29,29 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I -! USE count_I + USE rint_I +! USE count_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J - INTEGER, INTENT(INOUT) :: INV - REAL(DOUBLE), INTENT(IN) :: ODAMPJ + INTEGER, INTENT(INOUT) :: INV + REAL(DOUBLE), INTENT(IN) :: ODAMPJ !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPO, MTPN, MTP, I, NNCFF, MFJ - REAL(DOUBLE) :: EPS, FACTOR, POLDI, QOLDI, DNORM, DNFAC, SGN - LOGICAL :: CHECK + INTEGER :: MTPO, MTPN, MTP, I, NNCFF, MFJ + REAL(DOUBLE) :: EPS, FACTOR, POLDI, QOLDI, DNORM, DNFAC, SGN + LOGICAL :: CHECK !----------------------------------------------- ! ! ! Initialization ! !ww EPS = 0.1D 00*ACCY - EPS = 0.01D00*ACCY - CHECK = .NOT.NOINVT(J) + EPS = 0.01D00*ACCY + CHECK = .NOT.NOINVT(J) ! ! Damp orbital J using the damping factor ABS (ODAMP(J)): ODAMP(J) ! is restricted to the open interval (-1,1) by DATSCF ; the meaning @@ -64,80 +64,80 @@ SUBROUTINE DAMPOR(J, INV, ODAMPJ) !XHH odampj goes to the argument ! ODAMPJ = ABS (ODAMP(J)) ! - IF (ODAMPJ > EPS) THEN + IF (ODAMPJ > EPS) THEN ! - FACTOR = 1.0D00 - ODAMPJ + FACTOR = 1.0D00 - ODAMPJ ! PZ(J) = FACTOR*P0 + ODAMPJ*PZ(J) ! - MTPO = MF(J) - MTPN = MTP0 - MTP0 = MTPO + MTPO = MF(J) + MTPN = MTP0 + MTP0 = MTPO ! - MTP = MAX(MTPN,MTPO) - DO I = 1, MTP - POLDI = PF(I,J) - PF(I,J) = FACTOR*P(I) + ODAMPJ*PF(I,J) - P(I) = POLDI - QOLDI = QF(I,J) - QF(I,J) = FACTOR*Q(I) + ODAMPJ*QF(I,J) - Q(I) = QOLDI - END DO + MTP = MAX(MTPN,MTPO) + DO I = 1, MTP + POLDI = PF(I,J) + PF(I,J) = FACTOR*P(I) + ODAMPJ*PF(I,J) + P(I) = POLDI + QOLDI = QF(I,J) + QF(I,J) = FACTOR*Q(I) + ODAMPJ*QF(I,J) + Q(I) = QOLDI + END DO ! ! Compute normalization factor ! - MF(J) = MTP - DNORM = RINT(J,J,0) - DNFAC = 1.0D00/SQRT(DNORM) + MF(J) = MTP + DNORM = RINT(J,J,0) + DNFAC = 1.0D00/SQRT(DNORM) ! ! Determine if inversion is necessary ! - IF (CHECK) THEN - CALL COUNT (PF(:NNNP,J), MTP, NNCFF, SGN) - IF (SGN < 0.0D00) THEN - INV = INV + 1 - DNFAC = -DNFAC - ENDIF - ENDIF + IF (CHECK) THEN + CALL COUNT (PF(:NNNP,J), MTP, NNCFF, SGN) + IF (SGN < 0.0D00) THEN + INV = INV + 1 + DNFAC = -DNFAC + ENDIF + ENDIF ! - PZ(J) = PZ(J)*DNFAC - PF(:MTP,J) = DNFAC*PF(:MTP,J) - QF(:MTP,J) = DNFAC*QF(:MTP,J) + PZ(J) = PZ(J)*DNFAC + PF(:MTP,J) = DNFAC*PF(:MTP,J) + QF(:MTP,J) = DNFAC*QF(:MTP,J) ! ! Find new MF(J) ! - MFJ = MTP + 1 - 3 CONTINUE - MFJ = MFJ - 1 - IF (ABS(PF(MFJ,J)) < EPS) THEN - PF(MFJ,J) = 0.0D00 - QF(MFJ,J) = 0.0D00 - GO TO 3 - ELSE - MF(J) = MFJ - ENDIF -! - ELSE -! - PZ(J) = P0 -! - MTPO = MF(J) - MTPN = MTP0 - MTP0 = MTPO -! - MTP = MAX(MTPN,MTPO) - DO I = 1, MTP - POLDI = PF(I,J) - PF(I,J) = P(I) - P(I) = POLDI - QOLDI = QF(I,J) - QF(I,J) = Q(I) - Q(I) = QOLDI - END DO -! - MF(J) = MTP -! - ENDIF -! - RETURN - END SUBROUTINE DAMPOR + MFJ = MTP + 1 + 3 CONTINUE + MFJ = MFJ - 1 + IF (ABS(PF(MFJ,J)) < EPS) THEN + PF(MFJ,J) = 0.0D00 + QF(MFJ,J) = 0.0D00 + GO TO 3 + ELSE + MF(J) = MFJ + ENDIF +! + ELSE +! + PZ(J) = P0 +! + MTPO = MF(J) + MTPN = MTP0 + MTP0 = MTPO +! + MTP = MAX(MTPN,MTPO) + DO I = 1, MTP + POLDI = PF(I,J) + PF(I,J) = P(I) + P(I) = POLDI + QOLDI = QF(I,J) + QF(I,J) = Q(I) + Q(I) = QOLDI + END DO +! + MF(J) = MTP +! + ENDIF +! + RETURN + END SUBROUTINE DAMPOR diff --git a/src/appl/rmcdhf90_mpi/dampor_I.f90 b/src/appl/rmcdhf90_mpi/dampor_I.f90 index 75258c5c3..47d78b116 100644 --- a/src/appl/rmcdhf90_mpi/dampor_I.f90 +++ b/src/appl/rmcdhf90_mpi/dampor_I.f90 @@ -1,13 +1,13 @@ - MODULE dampor_I + MODULE dampor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:22:36 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dampor (J, INV, ODAMPJ) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(INOUT) :: INV - REAL(DOUBLE), INTENT(IN) :: ODAMPJ - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dampor (J, INV, ODAMPJ) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(INOUT) :: INV + REAL(DOUBLE), INTENT(IN) :: ODAMPJ + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/defcor.f90 b/src/appl/rmcdhf90_mpi/defcor.f90 index 163134c74..0a0a85dca 100644 --- a/src/appl/rmcdhf90_mpi/defcor.f90 +++ b/src/appl/rmcdhf90_mpi/defcor.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE DEFCOR(J) + SUBROUTINE DEFCOR(J) ! * ! Compute the deferred corrections for orbital J . * ! * ! Last updated: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE wave_C @@ -21,21 +21,21 @@ SUBROUTINE DEFCOR(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: W3 = 1.0D00/120.0D00 - REAL(DOUBLE), PARAMETER :: W2 = -15.0D00*W3 - REAL(DOUBLE), PARAMETER :: W1 = 40.0D00*W3 + REAL(DOUBLE), PARAMETER :: W3 = 1.0D00/120.0D00 + REAL(DOUBLE), PARAMETER :: W2 = -15.0D00*W3 + REAL(DOUBLE), PARAMETER :: W1 = 40.0D00*W3 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, MFJM3, MFJM2 - LOGICAL :: FIRST + INTEGER :: I, MFJM3, MFJM2 + LOGICAL :: FIRST !----------------------------------------------- ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! The deferred corrections for the first two points are ! unnecessary, because the integration always commences @@ -43,33 +43,33 @@ SUBROUTINE DEFCOR(J) ! deferred correction at the third and subsequent points ! only ! - IF (FIRST) THEN - DP(:2) = 0.0D00 - DQ(:2) = 0.0D00 - FIRST = .FALSE. - ENDIF + IF (FIRST) THEN + DP(:2) = 0.0D00 + DQ(:2) = 0.0D00 + FIRST = .FALSE. + ENDIF ! ! Intermediate points ! - MFJM3 = MF(J) - 3 - DO I = 3, MFJM3 + MFJM3 = MF(J) - 3 + DO I = 3, MFJM3 ! DP(I) = W3*(PF(I + 3,J) - PF(I - 2,J)) + & W2*(PF(I + 2,J) - PF(I - 1,J)) + & - W1*(PF(I + 1,J) - PF(I,J)) + W1*(PF(I + 1,J) - PF(I,J)) ! DQ(I) = W3*(QF(I + 3,J) - QF(I - 2,J)) + & W2*(QF(I + 2,J) - QF(I - 1,J)) + & - W1*(QF(I + 1,J) - QF(I,J)) + W1*(QF(I + 1,J) - QF(I,J)) ! - END DO + END DO ! ! Set remaining deferred corrections to zero: slopes are ! small in this region ! - MFJM2 = MF(J) - 2 - DP(MFJM2:N) = 0.0D00 - DQ(MFJM2:N) = 0.0D00 + MFJM2 = MF(J) - 2 + DP(MFJM2:N) = 0.0D00 + DQ(MFJM2:N) = 0.0D00 ! - RETURN - END SUBROUTINE DEFCOR + RETURN + END SUBROUTINE DEFCOR diff --git a/src/appl/rmcdhf90_mpi/defcor_I.f90 b/src/appl/rmcdhf90_mpi/defcor_I.f90 index eb9bee78b..3a454b279 100644 --- a/src/appl/rmcdhf90_mpi/defcor_I.f90 +++ b/src/appl/rmcdhf90_mpi/defcor_I.f90 @@ -1,10 +1,10 @@ - MODULE defcor_I + MODULE defcor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE defcor (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE defcor (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/dsubrs.f90 b/src/appl/rmcdhf90_mpi/dsubrs.f90 index 75a991bee..826896a3f 100644 --- a/src/appl/rmcdhf90_mpi/dsubrs.f90 +++ b/src/appl/rmcdhf90_mpi/dsubrs.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) + REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) ! * ! The coefficients d for I = r, J = s are calculated here. * ! rs * @@ -29,13 +29,13 @@ REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) ! by parameter jblock ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE hblock_C @@ -44,29 +44,29 @@ REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER , INTENT(IN) :: J - INTEGER :: JBLOCK - LOGICAL , INTENT(IN) :: EOL + INTEGER :: I + INTEGER , INTENT(IN) :: J + INTEGER :: JBLOCK + LOGICAL , INTENT(IN) :: EOL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, KCMIN, IK, JK + INTEGER :: K, KCMIN, IK, JK !----------------------------------------------- - - IF (EOL) THEN - DSUBRS = 0.D0 - DO K = 1, NEVBLK(JBLOCK) - KCMIN = K + NCMINPAST(JBLOCK) - IK = I + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) - JK = J + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) - DSUBRS = DSUBRS + EVEC(IK)*EVEC(JK)*WT(KCMIN) - END DO - ELSE IF (I == J) THEN - DSUBRS = WT(I) - ELSE - DSUBRS = 0.D0 - ENDIF - - RETURN - END FUNCTION DSUBRS + + IF (EOL) THEN + DSUBRS = 0.D0 + DO K = 1, NEVBLK(JBLOCK) + KCMIN = K + NCMINPAST(JBLOCK) + IK = I + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) + JK = J + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK) + DSUBRS = DSUBRS + EVEC(IK)*EVEC(JK)*WT(KCMIN) + END DO + ELSE IF (I == J) THEN + DSUBRS = WT(I) + ELSE + DSUBRS = 0.D0 + ENDIF + + RETURN + END FUNCTION DSUBRS diff --git a/src/appl/rmcdhf90_mpi/dsubrs_I.f90 b/src/appl/rmcdhf90_mpi/dsubrs_I.f90 index e5b89dcbb..bbf2031b5 100644 --- a/src/appl/rmcdhf90_mpi/dsubrs_I.f90 +++ b/src/appl/rmcdhf90_mpi/dsubrs_I.f90 @@ -1,13 +1,13 @@ - MODULE dsubrs_I + MODULE dsubrs_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION dsubrs (EOL, I, J, JBLOCK) - LOGICAL, INTENT(IN) :: EOL - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER :: JBLOCK - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION dsubrs (EOL, I, J, JBLOCK) + LOGICAL, INTENT(IN) :: EOL + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER :: JBLOCK + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/eigen.f90 b/src/appl/rmcdhf90_mpi/eigen.f90 index 5fbd8224a..29b068d21 100644 --- a/src/appl/rmcdhf90_mpi/eigen.f90 +++ b/src/appl/rmcdhf90_mpi/eigen.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION EIGEN (J) + REAL(KIND(0.0D0)) FUNCTION EIGEN (J) ! * ! This function computes an estimate of the energy of orbital J . * ! * @@ -9,13 +9,13 @@ REAL(KIND(0.0D0)) FUNCTION EIGEN (J) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE orb_C @@ -25,70 +25,70 @@ REAL(KIND(0.0D0)) FUNCTION EIGEN (J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I - USE dpbdt_I + USE quad_I + USE dpbdt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4, PIECE5 + INTEGER :: I + REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4, PIECE5 !----------------------------------------------- ! ! ! Initialization ! - MTP = MF(J) + MTP = MF(J) ! ! Exchange term ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)*XQ(I)-QF(I,J)*XP(I))*RPOR(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = C*PIECE1 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)*XQ(I)-QF(I,J)*XP(I))*RPOR(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = C*PIECE1 ! ! Direct term ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)**2 + QF(I,J)**2)*YP(I)*RPOR(I) - END DO - CALL QUAD (PIECE2) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)**2 + QF(I,J)**2)*YP(I)*RPOR(I) + END DO + CALL QUAD (PIECE2) ! ! Kinetic energy terms ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = QF(I,J)**2*RP(I) - END DO - CALL QUAD (PIECE3) - PIECE3 = 2.0D00*C*C*PIECE3 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = QF(I,J)**2*RP(I) + END DO + CALL QUAD (PIECE3) + PIECE3 = 2.0D00*C*C*PIECE3 ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,J)*QF(I,J))*RPOR(I) - END DO - CALL QUAD (PIECE4) - PIECE4 = -2.0D00*DBLE(NAK(J))*C*PIECE4 + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,J)*QF(I,J))*RPOR(I) + END DO + CALL QUAD (PIECE4) + PIECE4 = -2.0D00*DBLE(NAK(J))*C*PIECE4 ! - CALL DPBDT (J) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = PF(I,J)*TB(I) - QF(I,J)*TA(I) - END DO - CALL QUAD (PIECE5) - PIECE5 = C*PIECE5/H + CALL DPBDT (J) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = PF(I,J)*TB(I) - QF(I,J)*TA(I) + END DO + CALL QUAD (PIECE5) + PIECE5 = C*PIECE5/H ! ! Assembly ! - EIGEN = PIECE1 + PIECE2 + PIECE3 + PIECE4 + PIECE5 + EIGEN = PIECE1 + PIECE2 + PIECE3 + PIECE4 + PIECE5 ! - RETURN + RETURN ! - END FUNCTION EIGEN + END FUNCTION EIGEN diff --git a/src/appl/rmcdhf90_mpi/eigen_I.f90 b/src/appl/rmcdhf90_mpi/eigen_I.f90 index 0cebba276..9e1b4dad4 100644 --- a/src/appl/rmcdhf90_mpi/eigen_I.f90 +++ b/src/appl/rmcdhf90_mpi/eigen_I.f90 @@ -1,10 +1,10 @@ - MODULE eigen_I + MODULE eigen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION eigen (J) - INTEGER, INTENT(IN) :: J - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION eigen (J) + INTEGER, INTENT(IN) :: J + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/endsum.f90 b/src/appl/rmcdhf90_mpi/endsum.f90 index cb51dffef..8be7e2c71 100644 --- a/src/appl/rmcdhf90_mpi/endsum.f90 +++ b/src/appl/rmcdhf90_mpi/endsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENDSUM + SUBROUTINE ENDSUM ! * ! Generates the last part of rscf92.sum (on stream 24). * ! * @@ -12,13 +12,13 @@ SUBROUTINE ENDSUM ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE eigv_C USE orb_C @@ -28,9 +28,9 @@ SUBROUTINE ENDSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I - USE engoutgg_I - USE csfwgt_I + USE rint_I + USE engoutgg_I + USE csfwgt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -41,43 +41,43 @@ SUBROUTINE ENDSUM ! ! Write out the orbital properties ! - WRITE (24, 301) - DO I = 1, NW + WRITE (24, 301) + DO I = 1, NW WRITE (24, 302) NP(I),NH(I),E(I),PZ(I),GAMA(I),PF(2,I),QF(2,I), & - SCNSTY(I), MF(I) - END DO + SCNSTY(I), MF(I) + END DO ! - WRITE (24, 303) - DO I = 1, NW - WA = RINT(I,I,-1) - WB = RINT(I,I,1) - WC = RINT(I,I,2) + WRITE (24, 303) + DO I = 1, NW + WA = RINT(I,I,-1) + WB = RINT(I,I,1) + WC = RINT(I,I,2) WD = RINT (I,I, 4) WE = 0.d0 IF (NH(I) /= 's ' .AND. NH(i) /= 'p-') then WE = RINT(I,I,-3) END IF WRITE (24,304) NP(I),NH(I),WE,WA,WB,WC,WD, UCF(I) - END DO + END DO ! - IF (NCMIN /= 0) THEN - MODE = 0 + IF (NCMIN /= 0) THEN + MODE = 0 CALL ENGOUTGG (EVAL,ICCMIN,NCMIN,MODE) -!GG CALL ENGOUT (EVAL, IATJPO, IASPAR, ICCMIN, NCMIN, MODE) - CALL CSFWGT (.FALSE.) - ENDIF +!GG CALL ENGOUT (EVAL, IATJPO, IASPAR, ICCMIN, NCMIN, MODE) + CALL CSFWGT (.FALSE.) + ENDIF ! - CLOSE(24) + CLOSE(24) ! - RETURN + RETURN ! 301 FORMAT(/,'Radial wavefunction summary:'/,/,67X,'Self'/,'Subshell',6X,'e',& - 13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',3X,'Consistency',' MTP'/) - 302 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,3(D11.3),I5) + 13X,'p0',5X,'gamma',5X,'P(2)',7X,'Q(2)',3X,'Consistency',' MTP'/) + 302 FORMAT(1X,I2,A2,1X,1P,D17.10,1P,D11.3,0P,F6.2,1P,3(D11.3),I5) 303 FORMAT (/18X,'-3',14X,'-1',29X,'2',14x,'4',5X,'Generalised' & /'Subshell',4X,'< r >',8X,'< r >',8X,'< r >',8X, & '< r >',8X,'< r >',6X,'occupation'/) 304 FORMAT (1X,1I2,1A2,1X,1P,6D15.5) - RETURN + RETURN ! - END SUBROUTINE ENDSUM + END SUBROUTINE ENDSUM diff --git a/src/appl/rmcdhf90_mpi/endsum_I.f90 b/src/appl/rmcdhf90_mpi/endsum_I.f90 index e5a24ce22..991069be6 100644 --- a/src/appl/rmcdhf90_mpi/endsum_I.f90 +++ b/src/appl/rmcdhf90_mpi/endsum_I.f90 @@ -1,10 +1,10 @@ - MODULE endsum_I + MODULE endsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE endsum + SUBROUTINE endsum !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/engoutgg.f90 b/src/appl/rmcdhf90_mpi/engoutgg.f90 index 5ee154e07..2397eb978 100644 --- a/src/appl/rmcdhf90_mpi/engoutgg.f90 +++ b/src/appl/rmcdhf90_mpi/engoutgg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) + SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -16,13 +16,13 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE jlabl_C, LABJ=>JLBR, LABP=>JLBP USE blkidx_C @@ -35,30 +35,30 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - INTEGER, INTENT(IN) :: ILEV(NN) - REAL(DOUBLE), INTENT(IN) :: E(NN) + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: ILEV(NN) + REAL(DOUBLE), INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, JBLOCK, I, IP, JTOT - REAL(DOUBLE) :: EAV, EAU, ECM, EEV + REAL(DOUBLE) :: EAV, EAU, ECM, EEV !----------------------------------------------- ! ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - JBLOCK = IDXBLK(J) - EAV = EAVBLK(JBLOCK) - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + JBLOCK = IDXBLK(J) + EAV = EAVBLK(JBLOCK) + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN ip = 2 @@ -66,22 +66,22 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 jblock = idxblk(j) JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -90,21 +90,21 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV -!GG IP = (IPAR(J)+3)/2 + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV +!GG IP = (IPAR(J)+3)/2 jblock = idxblk(j) JTOT = IABS(JPGG(jblock)) IF(JPGG(jblock) >= 0) THEN @@ -113,19 +113,19 @@ SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) ip = 1 END IF WRITE (24, 302) I, LABJ(JTOT), LABP(IP), EAU, ECM, EEV -!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF +!GG WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV + END DO + ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,4X,2A4,1P,3D21.12) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,4X,2A4,1P,3D21.12) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! END SUBROUTINE ENGOUTGG diff --git a/src/appl/rmcdhf90_mpi/engoutgg_I.f90 b/src/appl/rmcdhf90_mpi/engoutgg_I.f90 index dd05d1705..70db01503 100644 --- a/src/appl/rmcdhf90_mpi/engoutgg_I.f90 +++ b/src/appl/rmcdhf90_mpi/engoutgg_I.f90 @@ -1,14 +1,14 @@ - MODULE engoutgg_I + MODULE engoutgg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ENGOUTGG(E,ILEV,NN,MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/estim.f90 b/src/appl/rmcdhf90_mpi/estim.f90 index 1a98cc7c9..e4a665fd1 100644 --- a/src/appl/rmcdhf90_mpi/estim.f90 +++ b/src/appl/rmcdhf90_mpi/estim.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ESTIM(J) + SUBROUTINE ESTIM(J) ! * ! This subprogram implements Part 1 of Algorithm 7.1 of C Froese * ! Fischer, Comput Phys Rep, 3 (1986) 320-321. * @@ -9,10 +9,10 @@ SUBROUTINE ESTIM(J) ! * !*********************************************************************** !...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE def_C USE grid_C @@ -22,23 +22,23 @@ SUBROUTINE ESTIM(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NPJ, NAKABS - REAL(DOUBLE) :: ALPHA, CSQ, FNREL, FKABS, FKAP2, ZALPHA, GAMMA, EBYM + INTEGER :: NPJ, NAKABS + REAL(DOUBLE) :: ALPHA, CSQ, FNREL, FKABS, FKAP2, ZALPHA, GAMMA, EBYM !----------------------------------------------- ! ! Initializations ! - ALPHA = 1.0D00/C - CSQ = C*C - NPJ = NP(J) - NAKABS = ABS(NAK(J)) - FNREL = DBLE(NPJ - NAKABS) - FKABS = DBLE(NAKABS) - FKAP2 = FKABS*FKABS + ALPHA = 1.0D00/C + CSQ = C*C + NPJ = NP(J) + NAKABS = ABS(NAK(J)) + FNREL = DBLE(NPJ - NAKABS) + FKABS = DBLE(NAKABS) + FKAP2 = FKABS*FKABS ! ! Set ZINF, the asymptotic charge seen by the electron ! @@ -46,31 +46,31 @@ SUBROUTINE ESTIM(J) ! ! Changed on 07/06/93 by WPW ! - ZINF = Z + DBLE((-NELEC) + 1) + ZINF = Z + DBLE((-NELEC) + 1) ! ! Set the lower bound ! - ZALPHA = ZINF*ALPHA - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL + 0.5D00))**2) - EPSMIN = (1.0D00 - EBYM)*CSQ - ELSE - EPSMIN = 0.25D00*CSQ/DBLE(NPJ*NPJ) - ENDIF - EMIN = EPSMIN + ZALPHA = ZINF*ALPHA + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL + 0.5D00))**2) + EPSMIN = (1.0D00 - EBYM)*CSQ + ELSE + EPSMIN = 0.25D00*CSQ/DBLE(NPJ*NPJ) + ENDIF + EMIN = EPSMIN ! ! Set the upper bound ! - ZALPHA = Z*ALPHA - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL - 0.5D00))**2) - EPSMAX = (1.0D00 - EBYM)*CSQ - ELSE - EPSMAX = CSQ + CSQ - ENDIF - EMAX = EPSMAX + ZALPHA = Z*ALPHA + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + FNREL - 0.5D00))**2) + EPSMAX = (1.0D00 - EBYM)*CSQ + ELSE + EPSMAX = CSQ + CSQ + ENDIF + EMAX = EPSMAX ! - RETURN - END SUBROUTINE ESTIM + RETURN + END SUBROUTINE ESTIM diff --git a/src/appl/rmcdhf90_mpi/estim_I.f90 b/src/appl/rmcdhf90_mpi/estim_I.f90 index 65fa1e39f..d20f4a03c 100644 --- a/src/appl/rmcdhf90_mpi/estim_I.f90 +++ b/src/appl/rmcdhf90_mpi/estim_I.f90 @@ -1,10 +1,10 @@ - MODULE estim_I + MODULE estim_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE estim (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE estim (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/fco.f90 b/src/appl/rmcdhf90_mpi/fco.f90 index ba94ca89f..98694fdf5 100644 --- a/src/appl/rmcdhf90_mpi/fco.f90 +++ b/src/appl/rmcdhf90_mpi/fco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) + REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) ! * ! This routine evaluates a coefficient * ! * @@ -26,68 +26,68 @@ REAL(KIND(0.0D0)) FUNCTION FCO (K, IR, IA, IB) !XHH 1997.03.05 ! !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, IIQA=>IQA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I USE IQ_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: K - INTEGER :: IR - INTEGER , INTENT(IN) :: IA - INTEGER , INTENT(IN) :: IB + INTEGER :: K + INTEGER :: IR + INTEGER , INTENT(IN) :: IA + INTEGER , INTENT(IN) :: IB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQA, IQF, KAPPA - REAL(DOUBLE) :: FAC + INTEGER :: IQA, IQF, KAPPA + REAL(DOUBLE) :: FAC !----------------------------------------------- ! - IF (IA == IB) THEN + IF (IA == IB) THEN ! IQA = IQ (IA,IR) -! IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) +! IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) ! - IF (K == 0) THEN - FCO = DBLE((IQA*(IQA - 1))/2) - ELSE - IQF = NKJ(IA) + 1 - IF (IQA == IQF) THEN - KAPPA = NAK(IA) - FAC = CLRX(KAPPA,K,KAPPA)*DBLE(IQA) - FCO = -0.5D0*FAC*FAC - ELSE - FCO = 0.D0 - ENDIF - ENDIF + IF (K == 0) THEN + FCO = DBLE((IQA*(IQA - 1))/2) + ELSE + IQF = NKJ(IA) + 1 + IF (IQA == IQF) THEN + KAPPA = NAK(IA) + FAC = CLRX(KAPPA,K,KAPPA)*DBLE(IQA) + FCO = -0.5D0*FAC*FAC + ELSE + FCO = 0.D0 + ENDIF + ENDIF ! - ELSE + ELSE ! - IF (K == 0) THEN + IF (K == 0) THEN FCO = DBLE (IQ (IA,IR)*IQ (IB,IR)) ! FCO = DBLE(IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8)*IBITS(& -! IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8)) - ELSE - FCO = 0.D0 - ENDIF +! IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8)) + ELSE + FCO = 0.D0 + ENDIF ! - ENDIF - RETURN + ENDIF + RETURN !* ! 300 FORMAT (/' ',1I2 ! : /' f (',1I2,1A2,',',1I2,1A2,') = ',1PD21.14, ! : /' ',1I3/) !* - END FUNCTION FCO + END FUNCTION FCO diff --git a/src/appl/rmcdhf90_mpi/fco_I.f90 b/src/appl/rmcdhf90_mpi/fco_I.f90 index 2e8e2377b..2bba93a8e 100644 --- a/src/appl/rmcdhf90_mpi/fco_I.f90 +++ b/src/appl/rmcdhf90_mpi/fco_I.f90 @@ -1,13 +1,13 @@ - MODULE fco_I + MODULE fco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION fco (K, IR, IA, IB) - INTEGER, INTENT(IN) :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION fco (K, IR, IA, IB) + INTEGER, INTENT(IN) :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/gco.f90 b/src/appl/rmcdhf90_mpi/gco.f90 index 084679281..d82fd2f8b 100644 --- a/src/appl/rmcdhf90_mpi/gco.f90 +++ b/src/appl/rmcdhf90_mpi/gco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) + REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! * ! This routine evaluates a coefficient * ! * @@ -19,46 +19,46 @@ REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! Written by Farid A Parpia, at Oxford Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, IIQA=>IQA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I USE IQ_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: K - INTEGER :: IR - INTEGER , INTENT(IN) :: IA - INTEGER , INTENT(IN) :: IB + INTEGER :: K + INTEGER :: IR + INTEGER , INTENT(IN) :: IA + INTEGER , INTENT(IN) :: IB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQA, IQB - REAL(DOUBLE) :: FAC -! LOGICAL :: FULLA, FULLB + INTEGER :: IQA, IQB + REAL(DOUBLE) :: FAC +! LOGICAL :: FULLA, FULLB !----------------------------------------------- ! IQA = IQ (IA,IR) IQB = IQ (IB,IR) -!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) -!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) - IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN - FAC = CLRX(NAK(IA),K,NAK(IB)) - GCO = -DBLE(IQA*IQB)*FAC*FAC - ELSE - GCO = 0.0D00 - ENDIF - - RETURN - END FUNCTION GCO +!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) +!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) + IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN + FAC = CLRX(NAK(IA),K,NAK(IB)) + GCO = -DBLE(IQA*IQB)*FAC*FAC + ELSE + GCO = 0.0D00 + ENDIF + + RETURN + END FUNCTION GCO diff --git a/src/appl/rmcdhf90_mpi/gco_I.f90 b/src/appl/rmcdhf90_mpi/gco_I.f90 index 5a759536a..f5a176568 100644 --- a/src/appl/rmcdhf90_mpi/gco_I.f90 +++ b/src/appl/rmcdhf90_mpi/gco_I.f90 @@ -1,13 +1,13 @@ - MODULE gco_I + MODULE gco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) - INTEGER :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) + INTEGER :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/getaldmpi.f90 b/src/appl/rmcdhf90_mpi/getaldmpi.f90 index 5f33fe83e..192a8145e 100644 --- a/src/appl/rmcdhf90_mpi/getaldmpi.f90 +++ b/src/appl/rmcdhf90_mpi/getaldmpi.f90 @@ -13,13 +13,13 @@ SUBROUTINE GETALDmpi ! Block version by Xinghong He Last revision: 13 Jul 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE def_C @@ -32,43 +32,43 @@ SUBROUTINE GETALDmpi !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getaldwt_I + USE getaldwt_I USE iq_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM, J, I - REAL(DOUBLE) :: SUM - LOGICAL :: GETYN, YES + INTEGER :: IQADUM, J, I + REAL(DOUBLE) :: SUM + LOGICAL :: GETYN, YES !----------------------------------------------- ! IF (myid .EQ. 0) THEN WRITE (ISTDE, *) '(E)AL type calculation; H(DC) will not be ', & - 'diagonalised;' - WRITE (ISTDE, *) 'getald ...' - WRITE (ISTDE, *) 'ncf=', NCF + 'diagonalised;' + WRITE (ISTDE, *) 'getald ...' + WRITE (ISTDE, *) 'ncf=', NCF END IF - - CALL ALLOC (WT, NCF, 'WT', 'GETALDmpi') - - IF (myid .EQ. 0) CALL GETALDWT (NCF, WT) + + CALL ALLOC (WT, NCF, 'WT', 'GETALDmpi') + + IF (myid .EQ. 0) CALL GETALDWT (NCF, WT) CALL MPI_Bcast (wt(1), ncf, MPI_DOUBLE_PRECISION, 0, & MPI_COMM_WORLD, ierr) - - DO J = 1, NW - SUM = 0.D0 - DO I = 1, NCF - SUM = SUM + WT(I)*DBLE(IQ(J,I)) - END DO - UCF(J) = SUM - END DO - - NCMIN = 0 - NSCF = 12 - NSIC = 2 + (NW - NFIX)/4 - ORTHST = .FALSE. - - RETURN + + DO J = 1, NW + SUM = 0.D0 + DO I = 1, NCF + SUM = SUM + WT(I)*DBLE(IQ(J,I)) + END DO + UCF(J) = SUM + END DO + + NCMIN = 0 + NSCF = 12 + NSIC = 2 + (NW - NFIX)/4 + ORTHST = .FALSE. + + RETURN END SUBROUTINE GETALDmpi diff --git a/src/appl/rmcdhf90_mpi/getaldmpi_I.f90 b/src/appl/rmcdhf90_mpi/getaldmpi_I.f90 index 72a10992c..143a1fc42 100644 --- a/src/appl/rmcdhf90_mpi/getaldmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/getaldmpi_I.f90 @@ -1,9 +1,9 @@ - MODULE getaldmpi_I + MODULE getaldmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getaldmpi - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getaldmpi + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/getaldwt.f90 b/src/appl/rmcdhf90_mpi/getaldwt.f90 index ebdc64831..28cfb2895 100644 --- a/src/appl/rmcdhf90_mpi/getaldwt.f90 +++ b/src/appl/rmcdhf90_mpi/getaldwt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETALDWT(NCF, WT) + SUBROUTINE GETALDWT(NCF, WT) ! ! Interactively determines the weights. ! @@ -9,84 +9,84 @@ SUBROUTINE GETALDWT(NCF, WT) ! Written by Xinghong He Last revision: 19 Mar 1999 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE itjpo_I + USE itjpo_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCF - REAL(DOUBLE) :: WT(NCF) + INTEGER, INTENT(IN) :: NCF + REAL(DOUBLE) :: WT(NCF) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, N159, NCMIN - REAL(DOUBLE) :: SUMWGT, FTJPOI + INTEGER :: I, N159, NCMIN + REAL(DOUBLE) :: SUMWGT, FTJPOI !----------------------------------------------- - + ! Select a method to assign level weights for ncmin > 1 case - - WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' - + + WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' + ! Let user try 10 times to get the correct input. 10 is BIG ! enough since the idea here is to allow user mistakes and ! at the same time to avoid an infinity loop. - - DO I = 1, 10 - READ (ISTDI, *) N159 - IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT - WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I - END DO - - IF (I > 10) STOP 'Must be running un-attended' - + + DO I = 1, 10 + READ (ISTDI, *) N159 + IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT + WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I + END DO + + IF (I > 10) STOP 'Must be running un-attended' + !------------------------------------------------------------------ - - SELECT CASE (N159) ! Equal weight - CASE (1) - WT = 1.D0 - SUMWGT = DBLE(NCF) - CASE (5) ! Standard weight - SUMWGT = 0.D0 - DO I = 1, NCF - FTJPOI = DBLE(ITJPO(I)) - WT(I) = FTJPOI - SUMWGT = SUMWGT + FTJPOI - END DO - CASE (9) ! User-input weight - - 123 CONTINUE + + SELECT CASE (N159) ! Equal weight + CASE (1) + WT = 1.D0 + SUMWGT = DBLE(NCF) + CASE (5) ! Standard weight + SUMWGT = 0.D0 + DO I = 1, NCF + FTJPOI = DBLE(ITJPO(I)) + WT(I) = FTJPOI + SUMWGT = SUMWGT + FTJPOI + END DO + CASE (9) ! User-input weight + + 123 CONTINUE WRITE (ISTDE, *) 'Enter the (relative) weights of the', NCF, & - ' levels :' - READ (ISTDI, *) (WT(I),I=1,NCMIN) - - SUMWGT = 0.D0 - DO I = 1, NCF - IF (WT(I) <= 0.D0) THEN - WRITE (ISTDE, *) 'Weights must exceed 0;' - GO TO 123 - ELSE - SUMWGT = SUMWGT + WT(I) - ENDIF - END DO - - CASE DEFAULT - WRITE (ISTDE, *) 'Impossible ! Because it was guarded' - STOP - END SELECT - - SUMWGT = 1.D0/SUMWGT - WT = SUMWGT*WT - - RETURN - END SUBROUTINE GETALDWT + ' levels :' + READ (ISTDI, *) (WT(I),I=1,NCMIN) + + SUMWGT = 0.D0 + DO I = 1, NCF + IF (WT(I) <= 0.D0) THEN + WRITE (ISTDE, *) 'Weights must exceed 0;' + GO TO 123 + ELSE + SUMWGT = SUMWGT + WT(I) + ENDIF + END DO + + CASE DEFAULT + WRITE (ISTDE, *) 'Impossible ! Because it was guarded' + STOP + END SELECT + + SUMWGT = 1.D0/SUMWGT + WT = SUMWGT*WT + + RETURN + END SUBROUTINE GETALDWT diff --git a/src/appl/rmcdhf90_mpi/getaldwt_I.f90 b/src/appl/rmcdhf90_mpi/getaldwt_I.f90 index be2f2b096..7c4949467 100644 --- a/src/appl/rmcdhf90_mpi/getaldwt_I.f90 +++ b/src/appl/rmcdhf90_mpi/getaldwt_I.f90 @@ -1,12 +1,12 @@ - MODULE getaldwt_I + MODULE getaldwt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getaldwt (NCF, WT) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: NCF - REAL(DOUBLE), DIMENSION(NCF), INTENT(INOUT) :: WT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getaldwt (NCF, WT) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: NCF + REAL(DOUBLE), DIMENSION(NCF), INTENT(INOUT) :: WT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/getoldmpi.f90 b/src/appl/rmcdhf90_mpi/getoldmpi.f90 index 335d703ce..8620101c7 100644 --- a/src/appl/rmcdhf90_mpi/getoldmpi.f90 +++ b/src/appl/rmcdhf90_mpi/getoldmpi.f90 @@ -1,14 +1,14 @@ !*********************************************************************** ! * - SUBROUTINE GETOLDmpi(IDBLK) + SUBROUTINE GETOLDmpi(IDBLK) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE blkidx_C @@ -21,50 +21,50 @@ SUBROUTINE GETOLDmpi(IDBLK) USE invt_C, ONLY: noinvt USE orthct_C USE ORB_C - USE ORBA_C, ONLY: IORDER - USE CORRE_C, ONLY: LCORRE + USE ORBA_C, ONLY: IORDER + USE CORRE_C, ONLY: LCORRE USE scf_C, ONLY: SCNSTY,METHOD USE MPI_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lodstate_I - USE getoldwt_I - USE prtrsl_I - USE getrsl_I + USE lodstate_I + USE getoldwt_I + USE prtrsl_I + USE getrsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: IDBLK(*)*8 + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM - INTEGER , DIMENSION(NNNW) :: INDX - INTEGER :: I, NSUBS, NORDER, LOC, NOFFSET, JBLOCK, J - LOGICAL :: GETYN, YES - CHARACTER :: RECORD*256 + INTEGER :: IQADUM + INTEGER , DIMENSION(NNNW) :: INDX + INTEGER :: I, NSUBS, NORDER, LOC, NOFFSET, JBLOCK, J + LOGICAL :: GETYN, YES + CHARACTER :: RECORD*256 !----------------------------------------------- - + !WRITE (istde,*) 'EOL type calculation;' - + ! lodstate fills ! nevblk(), ncmaxblk() ! ncmin, iccmin(1:ncmin) -- via items (memories allocated there) - - CALL ALLOC (NCMAXBLK, NBLOCK, 'NCMAXBLK', 'GETOLDmpi') - CALL ALLOC (NEVBLK, NBLOCK, 'NEVBLK', 'GETOLDmpi' ) + + CALL ALLOC (NCMAXBLK, NBLOCK, 'NCMAXBLK', 'GETOLDmpi') + CALL ALLOC (NEVBLK, NBLOCK, 'NEVBLK', 'GETOLDmpi' ) !cjb ncmaxblk & nevblk initialised in lodstate ! NEVBLK = 0 ! NCMAXBLK = 0 !cjb - + !cjb LODSTATE(NBLOCK, NCFBLK, IDBLK, NEVBLK, NCMAXBLK) -> (IDBLK) -!cjb CALL LODSTATE (NBLOCK, NCFBLK(1), IDBLK, NEVBLK, NCMAXBLK) +!cjb CALL LODSTATE (NBLOCK, NCFBLK(1), IDBLK, NEVBLK, NCMAXBLK) IF (myid == 0) THEN - CALL LODSTATE (IDBLK) + CALL LODSTATE (IDBLK) END IF !cjb @@ -88,25 +88,25 @@ SUBROUTINE GETOLDmpi(IDBLK) ! ! Allocate the storage for and set the weights ! - CALL ALLOC (WEIGHT, NCMIN, 'WEIGHT', 'GETOLDmpi') + CALL ALLOC (WEIGHT, NCMIN, 'WEIGHT', 'GETOLDmpi') - IF (myid == 0) THEN - CALL GETOLDWT (NDEF, NCMIN, WEIGHT) + IF (myid == 0) THEN + CALL GETOLDWT (NDEF, NCMIN, WEIGHT) END IF CALL MPI_Bcast (weight(1), ncmin, MPI_DOUBLE_PRECISION, 0, & MPI_COMM_WORLD, ierr) ! ! Eigenvector damping ! - CALL ALLOC (CDAMP, NCMIN, 'CDAMP', 'GETOLDmpi') + CALL ALLOC (CDAMP, NCMIN, 'CDAMP', 'GETOLDmpi') ! - CDAMP(:NCMIN) = 0.D0 + CDAMP(:NCMIN) = 0.D0 ! ! Print the list of all subshells ! IF (myid == 0) THEN - WRITE (ISTDE, *) 'Radial functions' - CALL PRTRSL + WRITE (ISTDE, *) 'Radial functions' + CALL PRTRSL END IF ! ! Determine which orbitals are to be varied, which are fixed. @@ -115,90 +115,90 @@ SUBROUTINE GETOLDmpi(IDBLK) ! Instead of broadcasting these quantities, we broadcast ! the intermediate result from GETRSL (see below) ! - LFIX(:NW) = .TRUE. - + LFIX(:NW) = .TRUE. + IF (myid == 0) THEN WRITE (ISTDE, *) 'Enter orbitals to be varied (Updating order)' - CALL GETRSL (INDX, NSUBS) + CALL GETRSL (INDX, NSUBS) END IF CALL MPI_Bcast (nsubs, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) IF (nsubs > 0) CALL MPI_Bcast (indx(1), nsubs, MPI_INTEGER, 0, & MPI_COMM_WORLD, ierr) - - LFIX(INDX(:NSUBS)) = .FALSE. + + LFIX(INDX(:NSUBS)) = .FALSE. !XHH give a big value, rather than zero to scnsty() - SCNSTY(INDX(:NSUBS)) = 1.D20 - NFIX = NW - NSUBS + SCNSTY(INDX(:NSUBS)) = 1.D20 + NFIX = NW - NSUBS IF (NFIX == NW) THEN IF(MYID == 0) & WRITE (ISTDE,*)'All subshell radial wavefunctions are fixed;',& - ' performing CI calculations with RCI.' + ' performing CI calculations with RCI.' END IF - + ! Determine orbital updating order - - NORDER = 0 - DO I = 1, NW - IORDER(I) = I - IF (LFIX(I)) CYCLE - NORDER = NORDER + 1 - IORDER(I) = INDX(NORDER) - END DO + + NORDER = 0 + DO I = 1, NW + IORDER(I) = I + IF (LFIX(I)) CYCLE + NORDER = NORDER + 1 + IORDER(I) = INDX(NORDER) + END DO ! !XHH added a array to store the index of the correlation functions ! - LCORRE(:NW) = .TRUE. + LCORRE(:NW) = .TRUE. - IF (myid == 0) THEN - WRITE (ISTDE, *) 'Which of these are spectroscopic orbitals?' - CALL GETRSL (INDX, NSUBS) + IF (myid == 0) THEN + WRITE (ISTDE, *) 'Which of these are spectroscopic orbitals?' + CALL GETRSL (INDX, NSUBS) END IF CALL MPI_Bcast (nsubs, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) IF (NSUBS .GT. 0) THEN CALL MPI_Bcast (indx(1), nsubs, MPI_INTEGER, 0, & MPI_COMM_WORLD, ierr) -!GG IF (NSUBS > 0) THEN - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - METHOD(LOC) = 1 - NOINVT(LOC) = .FALSE. - ODAMP(LOC) = 0.D0 - LCORRE(LOC) = .FALSE. - END DO - ENDIF - +!GG IF (NSUBS > 0) THEN + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + METHOD(LOC) = 1 + NOINVT(LOC) = .FALSE. + ODAMP(LOC) = 0.D0 + LCORRE(LOC) = .FALSE. + END DO + ENDIF + ! Set NSIC. It will be non-zero if all orbitals to be varied are ! spectroscopic orbitals - - NSIC = 4 + (NW - NFIX)/4 - DO I = 1, NW - IF (.NOT.(.NOT.LFIX(I) .AND. LCORRE(I))) CYCLE - NSIC = 0 - EXIT - END DO -! - NSCF = 24 - NSOLV = 3 - ORTHST = .TRUE. + + NSIC = 4 + (NW - NFIX)/4 + DO I = 1, NW + IF (.NOT.(.NOT.LFIX(I) .AND. LCORRE(I))) CYCLE + NSIC = 0 + EXIT + END DO +! + NSCF = 24 + NSOLV = 3 + ORTHST = .TRUE. ! ! Make the allocation for the auxiliary vector required ! by SUBROUTINE NEWCO ! - CALL ALLOC (RWTDUM, NCMIN, 'RWTDUM', 'GETOLDmpi') + CALL ALLOC (RWTDUM, NCMIN, 'RWTDUM', 'GETOLDmpi') ! ! Place the block numbers of the all ncmin eigenstate(wanted) ! in array idxblk ! - CALL ALLOC (IDXBLK, NCMIN, 'IDXBLK', 'GETOLDmpi') - NOFFSET = 0 - DO JBLOCK = 1, NBLOCK - DO J = 1, NEVBLK(JBLOCK) - IDXBLK(J+NOFFSET) = JBLOCK - END DO - NOFFSET = NOFFSET + NEVBLK(JBLOCK) - END DO - IF (NOFFSET /= NCMIN) STOP 'getold: ncmin trouble' - - RETURN + CALL ALLOC (IDXBLK, NCMIN, 'IDXBLK', 'GETOLDmpi') + NOFFSET = 0 + DO JBLOCK = 1, NBLOCK + DO J = 1, NEVBLK(JBLOCK) + IDXBLK(J+NOFFSET) = JBLOCK + END DO + NOFFSET = NOFFSET + NEVBLK(JBLOCK) + END DO + IF (NOFFSET /= NCMIN) STOP 'getold: ncmin trouble' + + RETURN END SUBROUTINE GETOLDmpi diff --git a/src/appl/rmcdhf90_mpi/getoldmpi_I.f90 b/src/appl/rmcdhf90_mpi/getoldmpi_I.f90 index 868049e41..5e65c904d 100644 --- a/src/appl/rmcdhf90_mpi/getoldmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/getoldmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE getoldmpi_I + MODULE getoldmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getoldmpi (IDBLK) - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getoldmpi (IDBLK) + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/getoldwt.f90 b/src/appl/rmcdhf90_mpi/getoldwt.f90 index 5c24286ee..bc2ea2f09 100644 --- a/src/appl/rmcdhf90_mpi/getoldwt.f90 +++ b/src/appl/rmcdhf90_mpi/getoldwt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) + SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) ! ! Interactively determines the weights for EOL calculation. ! It's modified to always ask the question for the weight @@ -10,85 +10,85 @@ SUBROUTINE GETOLDWT(NDEF, NCMIN, WT) ! Written by Xinghong He Last revision: 19 Mar 1999 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE iounit_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NDEF - INTEGER , INTENT(IN) :: NCMIN - REAL(DOUBLE) :: WT(NCMIN) + INTEGER :: NDEF + INTEGER , INTENT(IN) :: NCMIN + REAL(DOUBLE) :: WT(NCMIN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, N159 - REAL(DOUBLE) :: SUMWGT + INTEGER :: I, N159 + REAL(DOUBLE) :: SUMWGT !----------------------------------------------- - + ! Standard weights: ncmin=1, OL calculation - - IF (NCMIN == 1) THEN - WT(1) = -1.D0 - RETURN - ENDIF - + + IF (NCMIN == 1) THEN + WT(1) = -1.D0 + RETURN + ENDIF + ! Select a method to assign level weights for ncmin > 1 case - - WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' - + + WRITE (ISTDE, *) 'level weights (1 equal; 5 standard; 9 user)' + ! Let user try 10 times to get the correct input. 10 is BIG ! enough since the idea here is to allow user mistakes and ! at the same time to avoid an infinity loop. - - DO I = 1, 10 - READ (ISTDI, *) N159 - IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT - WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I - END DO + + DO I = 1, 10 + READ (ISTDI, *) N159 + IF (N159==1 .OR. N159==5 .OR. N159==9) EXIT + WRITE (ISTDE, *) 'Input not correct, do it again. tried=', I + END DO IF (NDEF.EQ.0) THEN WRITE(734,*) n159,'! level weights' END IF - - IF (I > 10) STOP - + + IF (I > 10) STOP + !------------------------------------------------------------------ - - SELECT CASE (N159) ! Equal weight - CASE (1) - WT = -2.D0 - CASE (5) ! Standard weight - WT = -1.D0 - CASE (9) ! User-input weight - - 123 CONTINUE + + SELECT CASE (N159) ! Equal weight + CASE (1) + WT = -2.D0 + CASE (5) ! Standard weight + WT = -1.D0 + CASE (9) ! User-input weight + + 123 CONTINUE WRITE (ISTDE, *) 'Enter the (relative) weights of the', NCMIN, & - ' levels :' - READ (ISTDI, *) (WT(I),I=1,NCMIN) - - SUMWGT = 0.D0 - DO I = 1, NCMIN - IF (WT(I) <= 0.D0) THEN - WRITE (ISTDE, *) 'Weights must exceed 0;' - GO TO 123 - ELSE - SUMWGT = SUMWGT + WT(I) - ENDIF - END DO - SUMWGT = 1.D0/SUMWGT - WT = SUMWGT*WT - - CASE DEFAULT - WRITE (ISTDE, *) 'Impossible ! Because it was guarded' - STOP - END SELECT - - RETURN - END SUBROUTINE GETOLDWT + ' levels :' + READ (ISTDI, *) (WT(I),I=1,NCMIN) + + SUMWGT = 0.D0 + DO I = 1, NCMIN + IF (WT(I) <= 0.D0) THEN + WRITE (ISTDE, *) 'Weights must exceed 0;' + GO TO 123 + ELSE + SUMWGT = SUMWGT + WT(I) + ENDIF + END DO + SUMWGT = 1.D0/SUMWGT + WT = SUMWGT*WT + + CASE DEFAULT + WRITE (ISTDE, *) 'Impossible ! Because it was guarded' + STOP + END SELECT + + RETURN + END SUBROUTINE GETOLDWT diff --git a/src/appl/rmcdhf90_mpi/getoldwt_I.f90 b/src/appl/rmcdhf90_mpi/getoldwt_I.f90 index ec8e8c5b3..f8fcf1d00 100644 --- a/src/appl/rmcdhf90_mpi/getoldwt_I.f90 +++ b/src/appl/rmcdhf90_mpi/getoldwt_I.f90 @@ -1,14 +1,14 @@ - MODULE getoldwt_I + MODULE getoldwt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getoldwt (NDEF, NCMIN, WT) - USE vast_kind_param,ONLY: DOUBLE - INTEGER :: NDEF + SUBROUTINE getoldwt (NDEF, NCMIN, WT) + USE vast_kind_param,ONLY: DOUBLE + INTEGER :: NDEF !VAST...Dummy argument NDEF is not referenced in this routine. - INTEGER, INTENT(IN) :: NCMIN - REAL(DOUBLE), DIMENSION(NCMIN), INTENT(INOUT) :: WT - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: NCMIN + REAL(DOUBLE), DIMENSION(NCMIN), INTENT(INOUT) :: WT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/getscdmpi.f90 b/src/appl/rmcdhf90_mpi/getscdmpi.f90 index bcfefa2f0..6e3c03c72 100644 --- a/src/appl/rmcdhf90_mpi/getscdmpi.f90 +++ b/src/appl/rmcdhf90_mpi/getscdmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) + SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) ! * ! Interactively determines the data governing the SCF problem. * ! * @@ -13,17 +13,17 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) ! Xinghong He 98-08-06 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP - USE COUN_C + USE COUN_C USE damp_C, ONLY: odamp, cdamp - USE DEF_C + USE DEF_C USE default_C USE fixd_C, ONLY: lfix USE iounit_C @@ -41,37 +41,37 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setisompi_I - USE setqic_I - USE radgrd_I - USE nucpot_I - USE setrwfmpi_I - USE getaldmpi_I - USE getoldmpi_I - USE convrt_I - USE getrsl_I + USE getyn_I + USE setisompi_I + USE setqic_I + USE radgrd_I + USE nucpot_I + USE setrwfmpi_I + USE getaldmpi_I + USE getoldmpi_I + USE convrt_I + USE getrsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(OUT) :: EOL - CHARACTER :: ISOFILE*(*) - CHARACTER :: RWFFILE*(*) - CHARACTER :: IDBLK(*)*8 + LOGICAL, INTENT(OUT) :: EOL + CHARACTER :: ISOFILE*(*) + CHARACTER :: RWFFILE*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*6, PARAMETER :: MYNAME = 'GETSCD' + CHARACTER*6, PARAMETER :: MYNAME = 'GETSCD' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM - INTEGER , DIMENSION(NNNW) :: INDX - INTEGER :: I, J, IEND, IBEG, LENTH, NSUBS, LOC - REAL(DOUBLE) :: ODAMPU, CDAMPU - LOGICAL :: YES - CHARACTER :: RECORD*80, CNUM*20 + INTEGER :: IQADUM + INTEGER , DIMENSION(NNNW) :: INDX + INTEGER :: I, J, IEND, IBEG, LENTH, NSUBS, LOC + REAL(DOUBLE) :: ODAMPU, CDAMPU + LOGICAL :: YES + CHARACTER :: RECORD*80, CNUM*20 !----------------------------------------------- ! ! Open, check, load data from, and close the .iso file @@ -80,65 +80,65 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Set default speed of light and grid parameters ! - C = CVAC + C = CVAC ! DEFAULT IS SET ABOVE IN SETISO (from isodata), JG (Lund, 2013) - IF (NPARM == 0) THEN - RNT = EXP((-65.D0/16.D0))/Z - H = 0.5D0**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.D0/16.D0))/Z + H = 0.5D0**4 + N = MIN(220,NNNP) + ELSE ! default comes here !CFF ... RNT should be Z-dependent - RNT = 2.0D-06/Z - H = 5.D-2 - N = NNNP - ENDIF - HP = 0.D0 + RNT = 2.0D-06/Z + H = 5.D-2 + N = NNNP + ENDIF + HP = 0.D0 ! ! ACCY is an estimate of the accuracy of the numerical procedures ! ACCY = H**6 - IF (NDEF /= 0) THEN - + IF (NDEF /= 0) THEN + IF (myid .EQ. 0) THEN !-------------------- WRITE (ISTDE,'(A)')'Change the default speed of',& - ' light or radial grid parameters? (y/n) ' - YES = GETYN() - IF (YES) THEN + ' light or radial grid parameters? (y/n) ' + YES = GETYN() + IF (YES) THEN WRITE (istde,*) 'Speed of light = ',CVAC,';', ' revise ?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter the revised value:' - READ (5, *) C - ENDIF + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter the revised value:' + READ (5, *) C + ENDIF ! ! Determine the parameters controlling the radial grid ! WRITE (ISTDE, *) 'The default radial grid parameters for ',& - 'this case are:' - WRITE (ISTDE, *) ' RNT = ', RNT - WRITE (ISTDE, *) ' H = ', H - WRITE (ISTDE, *) ' HP = ', HP - WRITE (ISTDE, *) ' N = ', N - WRITE (ISTDE, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (ISTDE, *) 'Enter H:' - READ (5, *) H - WRITE (ISTDE, *) 'Enter HP:' - READ (5, *) HP - WRITE (ISTDE, *) 'Enter N:' - READ (5, *) N + 'this case are:' + WRITE (ISTDE, *) ' RNT = ', RNT + WRITE (ISTDE, *) ' H = ', H + WRITE (ISTDE, *) ' HP = ', HP + WRITE (ISTDE, *) ' N = ', N + WRITE (ISTDE, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (ISTDE, *) 'Enter H:' + READ (5, *) H + WRITE (ISTDE, *) 'Enter HP:' + READ (5, *) HP + WRITE (ISTDE, *) 'Enter N:' + READ (5, *) N !b Revised grid WRITE (istde,*) 'Revised RNT = ', RNT WRITE (istde,*) 'Revised H = ', H WRITE (istde,*) 'Revised HP = ', HP WRITE (istde,*) 'Revised N = ', N - ENDIF - ENDIF + ENDIF + ENDIF ! !b !b read ACCY on input @@ -170,58 +170,58 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Generate $- r \times V_ (r)$ ! - CALL NUCPOT + CALL NUCPOT ! ! Load the subshell radial wavefunction estimates ! - CALL SETRWFMPI (RWFFILE) + CALL SETRWFMPI (RWFFILE) ! ! Set some defaults ! - THRESH = 0.05D0 - + THRESH = 0.05D0 + ! IORDER(I) = I ! Completely determined in GETOLDMPI - METHOD(:NW) = 3 - NOINVT(:NW) = .TRUE. + METHOD(:NW) = 3 + NOINVT(:NW) = .TRUE. !FF ... Revised Sep. 2014 -!CFF ODAMP(:NW) = 1.D0 - ODAMP(:NW) = 0.0D0 - SCNSTY(:NW) = 0.0D0 - - WHERE (NAK(:NW) < 0) - NNODEP(:NW) = NP(:NW) + NAK(:NW) - ELSEWHERE - NNODEP(:NW) = NP(:NW) - NAK(:NW) - 1 - END WHERE - - IF (DIAG) THEN - EOL = .FALSE. - CALL GETALDMPI ! (E)AL type calculation, +!CFF ODAMP(:NW) = 1.D0 + ODAMP(:NW) = 0.0D0 + SCNSTY(:NW) = 0.0D0 + + WHERE (NAK(:NW) < 0) + NNODEP(:NW) = NP(:NW) + NAK(:NW) + ELSEWHERE + NNODEP(:NW) = NP(:NW) - NAK(:NW) - 1 + END WHERE + + IF (DIAG) THEN + EOL = .FALSE. + CALL GETALDMPI ! (E)AL type calculation, ! H(DC) will not be diagonalised - ELSE IF (LFORDR) THEN - EOL = .TRUE. - CALL GETOLDMPI (IDBLK) ! EOL type calculation - ELSE + ELSE IF (LFORDR) THEN + EOL = .TRUE. + CALL GETOLDMPI (IDBLK) ! EOL type calculation + ELSE IF (MYID == 0) THEN EOL = .true. END IF CALL MPI_Bcast (EOL, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - IF (EOL) THEN - CALL GETOLDmpi (IDBLK) - ELSE - CALL GETALDmpi ! (E)AL type calculation, + IF (EOL) THEN + CALL GETOLDmpi (IDBLK) + ELSE + CALL GETALDmpi ! (E)AL type calculation, ! H(DC) will not be diagonalised - ENDIF - ENDIF - + ENDIF + ENDIF + IF(MYID == 0) THEN WRITE (istde,*) 'Enter the maximum number of SCF cycles:' READ (*,*) NSCF @@ -233,287 +233,287 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) ! ! Allow the user to modify other defaults ! - IF (NDEF /= 0) THEN + IF (NDEF /= 0) THEN IF(MYID == 0) THEN - WRITE (ISTDE, '(A)') 'Modify other defaults? (y/n) ' - YES = GETYN() + WRITE (ISTDE, '(A)') 'Modify other defaults? (y/n) ' + YES = GETYN() END IF CALL MPI_Bcast (yes, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - ELSE - YES = .FALSE. - ENDIF - - IF (.NOT.YES) RETURN + ELSE + YES = .FALSE. + ENDIF + + IF (.NOT.YES) RETURN !======================================================================= ! From here to end, "other defaults" are handled. For simplicity ! We'll let node-0 do the job and then broadcast results to all ! nodes. !======================================================================= !------------------------------------------- - IF (MYID == 0) THEN ! This is a _big_ IF + IF (MYID == 0) THEN ! This is a _big_ IF !------------------------------------------- ! ! THRESH ! WRITE (ISTDE,*)'An oscillation in the large-component of the ',& - 'radial wavefunction is diregarded' + 'radial wavefunction is diregarded' WRITE (ISTDE, *) 'for the purposes of node counting if its ', & - 'amplitude is less than 1/20 the' - WRITE (ISTDE, *) 'maximum amplitude. Revise this?' - YES = GETYN() - IF (YES) THEN - 3 CONTINUE - WRITE (ISTDE, *) 'Enter the new threshold value:' - READ (*, *) THRESH - IF (THRESH <= 0.D0) THEN - WRITE (ISTDE, *) MYNAME, ': This must exceed 0;' - GO TO 3 - ENDIF - ENDIF + 'amplitude is less than 1/20 the' + WRITE (ISTDE, *) 'maximum amplitude. Revise this?' + YES = GETYN() + IF (YES) THEN + 3 CONTINUE + WRITE (ISTDE, *) 'Enter the new threshold value:' + READ (*, *) THRESH + IF (THRESH <= 0.D0) THEN + WRITE (ISTDE, *) MYNAME, ': This must exceed 0;' + GO TO 3 + ENDIF + ENDIF YES = .FALSE. ! ! METHOD ! - + ! Piece only for printing... - - DO I = 1, 4 - - DO J = 1, NW - IF (.NOT.(METHOD(J)==I .AND. .NOT.LFIX(J))) CYCLE + + DO I = 1, 4 + + DO J = 1, NW + IF (.NOT.(METHOD(J)==I .AND. .NOT.LFIX(J))) CYCLE WRITE (ISTDE, *) 'Method ', I, ' is used for ', & 'integrating the radial differential ', & - 'equation for subshells' - GO TO 9 - END DO - - CYCLE - - 9 CONTINUE - IEND = 0 - DO J = 1, NW - IF (METHOD(J)==I .AND. .NOT.LFIX(J)) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - CALL CONVRT (NP(J), CNUM, LENTH) - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IBEG = IEND + 1 - IF (NAK(J) < 0) THEN - IEND = IBEG - RECORD(IBEG:IEND) = NH(J)(1:1) - ELSE - IEND = IBEG + 1 - RECORD(IBEG:IEND) = NH(J)(1:2) - ENDIF - ENDIF - IF (IEND <= 76) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - END DO - IF (IEND<=0 .OR. MYID/=0) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - END DO - + 'equation for subshells' + GO TO 9 + END DO + + CYCLE + + 9 CONTINUE + IEND = 0 + DO J = 1, NW + IF (METHOD(J)==I .AND. .NOT.LFIX(J)) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + CALL CONVRT (NP(J), CNUM, LENTH) + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IBEG = IEND + 1 + IF (NAK(J) < 0) THEN + IEND = IBEG + RECORD(IBEG:IEND) = NH(J)(1:1) + ELSE + IEND = IBEG + 1 + RECORD(IBEG:IEND) = NH(J)(1:2) + ENDIF + ENDIF + IF (IEND <= 76) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + END DO + IF (IEND<=0 .OR. MYID/=0) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + END DO + ! Reads user inputs and fills array indx(1:nsubs) where nsubs itself ! is an output from getrsl. ! METHOD(1:4) is the only output. indx() and nsubs are discarded - + WRITE (ISTDE, *) 'Select a different integration method for ',& - 'any subshell radial wavefunction?' - YES = GETYN() - IF (YES) THEN - DO I = 1, 4 - WRITE (ISTDE, *) 'Method ', I, ':' - CALL GETRSL (INDX, NSUBS) - DO J = 1, NSUBS - LOC = INDX(J) - IF (LFIX(LOC)) CYCLE - METHOD(LOC) = I - END DO - END DO - ENDIF + 'any subshell radial wavefunction?' + YES = GETYN() + IF (YES) THEN + DO I = 1, 4 + WRITE (ISTDE, *) 'Method ', I, ':' + CALL GETRSL (INDX, NSUBS) + DO J = 1, NSUBS + LOC = INDX(J) + IF (LFIX(LOC)) CYCLE + METHOD(LOC) = I + END DO + END DO + ENDIF ! ! NOINVT ! WRITE (ISTDE, *) 'The first oscillation of the large component' - - DO I = 1, NW - IF (.NOT.(NOINVT(I) .AND. .NOT.LFIX(I))) CYCLE + + DO I = 1, NW + IF (.NOT.(NOINVT(I) .AND. .NOT.LFIX(I))) CYCLE WRITE (ISTDE, *) 'of the following radial wavefunctions ', & - 'will be required to be positive' - GO TO 15 - END DO - + 'will be required to be positive' + GO TO 15 + END DO + WRITE(ISTDE,*)'of all radial wavefunctions will be required ',& - 'to be positive. Revise this?' - YES = GETYN() - GO TO 17 - 15 CONTINUE - IEND = 0 - DO I = 1, NW - IF (NOINVT(I) .AND. .NOT.LFIX(I)) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - CALL CONVRT (NP(I), CNUM, LENTH) - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IBEG = IEND + 1 - IF (NAK(I) < 0) THEN - IEND = IBEG - RECORD(IBEG:IEND) = NH(I)(1:1) - ELSE - IEND = IBEG + 1 - RECORD(IBEG:IEND) = NH(I)(1:2) - ENDIF - ENDIF - IF (IEND <= 76) CYCLE - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - END DO - IF (IEND > 0) WRITE (ISTDE, *) RECORD(1:IEND) - WRITE (ISTDE, *) 'Revise this?' - YES = GETYN() - 17 CONTINUE - IF (YES) THEN + 'to be positive. Revise this?' + YES = GETYN() + GO TO 17 + 15 CONTINUE + IEND = 0 + DO I = 1, NW + IF (NOINVT(I) .AND. .NOT.LFIX(I)) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + CALL CONVRT (NP(I), CNUM, LENTH) + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IBEG = IEND + 1 + IF (NAK(I) < 0) THEN + IEND = IBEG + RECORD(IBEG:IEND) = NH(I)(1:1) + ELSE + IEND = IBEG + 1 + RECORD(IBEG:IEND) = NH(I)(1:2) + ENDIF + ENDIF + IF (IEND <= 76) CYCLE + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + END DO + IF (IEND > 0) WRITE (ISTDE, *) RECORD(1:IEND) + WRITE (ISTDE, *) 'Revise this?' + YES = GETYN() + 17 CONTINUE + IF (YES) THEN WRITE(ISTDE,*)'Suppressing enforcement of positive first ',& - 'oscillation:' - CALL GETRSL (INDX, NSUBS) - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - NOINVT(LOC) = .TRUE. - END DO - ENDIF + 'oscillation:' + CALL GETRSL (INDX, NSUBS) + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + NOINVT(LOC) = .TRUE. + END DO + ENDIF ! ! ODAMP ! - DO I = 1, NW - IF (.NOT.(ODAMP(I)/=0.D0 .AND. .NOT.LFIX(I))) CYCLE + DO I = 1, NW + IF (.NOT.(ODAMP(I)/=0.D0 .AND. .NOT.LFIX(I))) CYCLE WRITE (ISTDE, *) 'Subshell accelerating parameters have ', & - 'been set. Revise these?' - YES = GETYN() - GO TO 20 - END DO + 'been set. Revise these?' + YES = GETYN() + GO TO 20 + END DO WRITE (ISTDE, *) 'Set accelerating parameters for subshell ', & - 'radial wavefunctions?' - YES = GETYN() - 20 CONTINUE - IF (YES) THEN + 'radial wavefunctions?' + YES = GETYN() + 20 CONTINUE + IF (YES) THEN WRITE (ISTDE, *) 'Different accelerating parameters for ', & - 'different subshell radial wavefunction?' - YES = GETYN() - IF (YES) THEN - 21 CONTINUE - WRITE (ISTDE, *) 'Enter an accelerating parameter' + 'different subshell radial wavefunction?' + YES = GETYN() + IF (YES) THEN + 21 CONTINUE + WRITE (ISTDE, *) 'Enter an accelerating parameter' WRITE (ISTDE, *) ' (0< ODAMP < 1 allows ODAMP to be ', & - 'reduced as convergence is approached;' + 'reduced as convergence is approached;' WRITE (ISTDE, *) ' -1 < ODAMP < 0 implies |ODAMP| is ', & - 'held constant):' - READ (*, *) ODAMPU - IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN - WRITE (ISTDE, *) MYNAME, ': Value out of range ...' - GO TO 21 - ELSE - CALL GETRSL (INDX, NSUBS) - DO I = 1, NSUBS - LOC = INDX(I) - IF (LFIX(LOC)) CYCLE - ODAMP(LOC) = ODAMPU - END DO - ENDIF - ELSE - 23 CONTINUE - WRITE (ISTDE, *) 'Enter the accelerating parameter' + 'held constant):' + READ (*, *) ODAMPU + IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN + WRITE (ISTDE, *) MYNAME, ': Value out of range ...' + GO TO 21 + ELSE + CALL GETRSL (INDX, NSUBS) + DO I = 1, NSUBS + LOC = INDX(I) + IF (LFIX(LOC)) CYCLE + ODAMP(LOC) = ODAMPU + END DO + ENDIF + ELSE + 23 CONTINUE + WRITE (ISTDE, *) 'Enter the accelerating parameter' WRITE (ISTDE, *) ' (0< ODAMP < 1 allows ODAMP to be ', & - 'reduced as convergence is approached;' + 'reduced as convergence is approached;' WRITE (ISTDE, *) ' -1 < ODAMP < 0 implies |ODAMP| is ', & - 'held constant):' - READ (*, *) ODAMPU - IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN - WRITE (ISTDE, *) MYNAME, ': Value out of range ...' - GO TO 23 - ELSE - WHERE (.NOT.LFIX(:NW)) - ODAMP(:NW) = ODAMPU - END WHERE - ENDIF - ENDIF - ENDIF + 'held constant):' + READ (*, *) ODAMPU + IF (ABS(ODAMPU)==0.D0 .OR. ABS(ODAMPU)>=1.D0) THEN + WRITE (ISTDE, *) MYNAME, ': Value out of range ...' + GO TO 23 + ELSE + WHERE (.NOT.LFIX(:NW)) + ODAMP(:NW) = ODAMPU + END WHERE + ENDIF + ENDIF + ENDIF ! ! CDAMP ! WRITE (ISTDE, *) 'Set accelerating parameters for the ', & - 'eigenvectors?' - YES = GETYN() - IF (YES) THEN + 'eigenvectors?' + YES = GETYN() + IF (YES) THEN WRITE (ISTDE, *) 'Different accelerating parameters ', & - 'for each eigenvector?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter an accelerating parameter for' - CALL CONVRT (NCMIN, RECORD, LENTH) - WRITE (ISTDE, *) ' each of the '//RECORD(1:LENTH)//' levels :' - READ (*, *) (CDAMP(I),I=1,NCMIN) - ELSE - WRITE (ISTDE, *) 'Enter the accelerating parameter:' - READ (*, *) CDAMPU - CDAMP(:NCMIN) = CDAMPU - ENDIF - ENDIF + 'for each eigenvector?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter an accelerating parameter for' + CALL CONVRT (NCMIN, RECORD, LENTH) + WRITE (ISTDE, *) ' each of the '//RECORD(1:LENTH)//' levels :' + READ (*, *) (CDAMP(I),I=1,NCMIN) + ELSE + WRITE (ISTDE, *) 'Enter the accelerating parameter:' + READ (*, *) CDAMPU + CDAMP(:NCMIN) = CDAMPU + ENDIF + ENDIF ! ! NSIC ! WRITE (ISTDE, *) 'Following the improvement of each of the ', & - 'subshell radial wavefunctions in turn, ' + 'subshell radial wavefunctions in turn, ' WRITE (ISTDE, *) 'the ', NSIC, ' least self-consistent', & - ' functions will be improved at the' + ' functions will be improved at the' WRITE (ISTDE, *) 'end of the first SCF cycle. Revise this ', & - 'setting?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter the number of additional ', 'improvements:' - READ (*, *) NSIC - ENDIF + 'setting?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter the number of additional ', 'improvements:' + READ (*, *) NSIC + ENDIF ! ! NSOLV ! WRITE (ISTDE, *) 'The maximum number of cycles in attempting ', & - 'to solve each radial equation is ' + 'to solve each radial equation is ' WRITE (ISTDE, *) NSOLV, ' times the principal quantum', & - ' number of the radial' + ' number of the radial' WRITE (ISTDE, *) 'wave-function to be estimated. ', & - 'Revise this setting?' - YES = GETYN() - IF (YES) THEN + 'Revise this setting?' + YES = GETYN() + IF (YES) THEN WRITE (ISTDE, *) 'Enter the factor that multiplies the ', & - 'principal quantum number:' - READ (*, *) NSOLV - ENDIF + 'principal quantum number:' + READ (*, *) NSOLV + ENDIF ! ! Orthogonalisation ! - IF (ORTHST) THEN + IF (ORTHST) THEN WRITE (ISTDE, *) 'Subshell radial wavefunctions will be ', & - 'Schmidt orthogonalised immediately' + 'Schmidt orthogonalised immediately' WRITE (ISTDE, *) 'following their estimation to all ', & - 'functions with poorer self-consistency.' - WRITE (ISTDE, *) ' Revise this?' - YES = GETYN() - IF (YES) ORTHST = .FALSE. - ELSE + 'functions with poorer self-consistency.' + WRITE (ISTDE, *) ' Revise this?' + YES = GETYN() + IF (YES) ORTHST = .FALSE. + ELSE WRITE (ISTDE, *) 'Subshell radial wavefunctions will be ', & - 'Schmidt orthogonalised at the end of' - WRITE (ISTDE, *) 'each SCF cycle. Revise this?' - YES = GETYN() - IF (YES) ORTHST = .TRUE. - ENDIF + 'Schmidt orthogonalised at the end of' + WRITE (ISTDE, *) 'each SCF cycle. Revise this?' + YES = GETYN() + IF (YES) ORTHST = .TRUE. + ENDIF !------------------------------------------- - ENDIF ! end of the _big_ IF + ENDIF ! end of the _big_ IF !------------------------------------------- CALL MPI_Bcast (thresh, 1, MPI_DOUBLE_PRECISION, 0, & @@ -529,5 +529,5 @@ SUBROUTINE GETSCDmpi(EOL, IDBLK, ISOFILE, RWFFILE) !cjb CALL MPI_Bcast (orthst, nw, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) CALL MPI_Bcast (orthst, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - RETURN + RETURN END SUBROUTINE GETSCDmpi diff --git a/src/appl/rmcdhf90_mpi/getscdmpi_I.f90 b/src/appl/rmcdhf90_mpi/getscdmpi_I.f90 index f42914e76..c5a670e39 100644 --- a/src/appl/rmcdhf90_mpi/getscdmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/getscdmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE getscdmpi_I + MODULE getscdmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:26:24 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:26:24 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getscdmpi (EOL, IDBLK, ISOFILE, RWFFILE) - LOGICAL, INTENT(OUT) :: EOL - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - CHARACTER (LEN = *) :: ISOFILE - CHARACTER (LEN = *) :: RWFFILE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getscdmpi (EOL, IDBLK, ISOFILE, RWFFILE) + LOGICAL, INTENT(OUT) :: EOL + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + CHARACTER (LEN = *) :: ISOFILE + CHARACTER (LEN = *) :: RWFFILE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/hmoutmpi.f90 b/src/appl/rmcdhf90_mpi/hmoutmpi.f90 index 1003c5e58..9d58d2dc0 100644 --- a/src/appl/rmcdhf90_mpi/hmoutmpi.f90 +++ b/src/appl/rmcdhf90_mpi/hmoutmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - subroutine hmoutmpi(myid, nprocs, ncf) + subroutine hmoutmpi(myid, nprocs, ncf) ! * ! Routine for printing the Hamiltonian matrix. * ! * @@ -8,26 +8,26 @@ subroutine hmoutmpi(myid, nprocs, ncf) ! Block Version by Xinghong He Last revision: 30 Jan 1999 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: double + USE vast_kind_param, ONLY: double USE hmat_C !GG USE mpi_C implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: myid - integer :: nprocs - integer, intent(in) :: ncf + integer :: myid + integer :: nprocs + integer, intent(in) :: ncf !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: ibeg, ico, idiag, list, iro + integer :: ibeg, ico, idiag, list, iro !----------------------------------------------- ! ibeg = 1 @@ -40,5 +40,5 @@ subroutine hmoutmpi(myid, nprocs, ncf) ibeg = idiag + 1 enddo ! - return + return end subroutine hmoutmpi diff --git a/src/appl/rmcdhf90_mpi/hmoutmpi_I.f90 b/src/appl/rmcdhf90_mpi/hmoutmpi_I.f90 index 5c99b24e7..2cc757b0c 100644 --- a/src/appl/rmcdhf90_mpi/hmoutmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/hmoutmpi_I.f90 @@ -1,14 +1,14 @@ - MODULE hmoutmpi_I + MODULE hmoutmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE hmoutmpi (MYID, NPROCS, NCF) - INTEGER :: MYID + SUBROUTINE hmoutmpi (MYID, NPROCS, NCF) + INTEGER :: MYID !VAST...Dummy argument MYID is not referenced in this routine. - INTEGER :: NPROCS + INTEGER :: NPROCS !VAST...Dummy argument NPROCS is not referenced in this routine. - INTEGER, INTENT(IN) :: NCF - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: NCF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/improvmpi.f90 b/src/appl/rmcdhf90_mpi/improvmpi.f90 index a858cef32..667625b32 100644 --- a/src/appl/rmcdhf90_mpi/improvmpi.f90 +++ b/src/appl/rmcdhf90_mpi/improvmpi.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) + SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) ! The difference from the serial version is that it calls MPI * ! version subroutines (setlagmpi, cofpotmpi, matrixmpi, newcompi). * ! * @@ -15,15 +15,15 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) ! Modified for ifort -i8 by A. Kramida (AK) Last update 22 Mar 2016 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE CORRE_C + USE CORRE_C USE damp_C USE def_C USE grid_C @@ -37,48 +37,48 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cofpotmpi_I - USE defcor_I - USE solve_I - USE orthsc_I -!GG USE matrixmpi_I -!GG USE newcompi_I - USE setlagmpi_I - USE quad_I - USE consis_I - USE dampck_I - USE dampor_I - USE orthy_I + USE cofpotmpi_I + USE defcor_I + USE solve_I + USE orthsc_I +!GG USE matrixmpi_I +!GG USE newcompi_I + USE setlagmpi_I + USE quad_I + USE consis_I + USE dampck_I + USE dampor_I + USE orthy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - REAL(DOUBLE), INTENT(INOUT) :: DAMPMX - LOGICAL :: EOL, LSORT + INTEGER :: J + REAL(DOUBLE), INTENT(INOUT) :: DAMPMX + LOGICAL :: EOL, LSORT !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P2 = 2.0D-01 - REAL(DOUBLE), PARAMETER :: P005 = 5.0D-03 - REAL(DOUBLE), PARAMETER :: P0001 = 1.0D-04 + REAL(DOUBLE), PARAMETER :: P2 = 2.0D-01 + REAL(DOUBLE), PARAMETER :: P005 = 5.0D-03 + REAL(DOUBLE), PARAMETER :: P0001 = 1.0D-04 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IPR, NPTS, INV, JP, NNP, I, NWWW INTEGER :: I_MPI, ndcof_max, ntot, i_last, iproc, ndcip, jproc INTEGER :: ifound, ind_buf, K - REAL(DOUBLE) :: ED1, GAMAJ, ED2, WTAEV, DNORM, DNFAC, DEL1, DEL2, ODAMPJ - LOGICAL :: FAIL, FIRST + REAL(DOUBLE) :: ED1, GAMAJ, ED2, WTAEV, DNORM, DNFAC, DEL1, DEL2, ODAMPJ + LOGICAL :: FAIL, FIRST REAL(DOUBLE), DIMENSION(:), POINTER :: da_buffer INTEGER, DIMENSION(:), POINTER :: nda_buffer,ndcof_buffer !----------------------------------------------- ! ! C Froese Fischer's IPR and ED1 parameter ! - DATA IPR/ 0/ - DATA ED1/ 0.D0/ - DATA FIRST/ .FALSE./ + DATA IPR/ 0/ + DATA ED1/ 0.D0/ + DATA FIRST/ .FALSE./ ! ! !----------------------------------------------------------------------- @@ -87,13 +87,13 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) I_MPI = MPI_INTEGER ! if (ISIZE.EQ.8) I_MPI = MPI_INTEGER8 ! - GAMAJ = GAMA(J) + GAMAJ = GAMA(J) ! ! C Froese Fischer's parameters IPR, ED1, ED2 are set and ! used in this routine and in DAMPCK ! - 1 CONTINUE - ED2 = E(J) + 1 CONTINUE + ED2 = E(J) ! ! Set up the exchange potential and arrays XU, XV as appropriate ! @@ -102,12 +102,12 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) ! Add in Lagrange-multiplier contribution ! Add in derivative-terms contribution ! - NPTS = N - CALL COFPOTmpi (EOL, J, NPTS) + NPTS = N + CALL COFPOTmpi (EOL, J, NPTS) ! ! Calculate deferred corrections ! - CALL DEFCOR (J) + CALL DEFCOR (J) ! ! Solve the Dirac equation ! @@ -127,7 +127,7 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) ! enddo ! ndcof = ndcof_buffer ! endif - INV = 0 + INV = 0 !cjb MPI_ALLREDUCE DA ! if (ndcof.gt.0) then ! call alloc(pda_buffer, ndcof, 8) @@ -201,99 +201,99 @@ SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX) call dalloc(ndcof_buffer,'ndcof_buffer','IMPROVmpi') endif - CALL SOLVE (J, FAIL, INV, JP, NNP) + CALL SOLVE (J, FAIL, INV, JP, NNP) ! ! Upon failure issue message; take corrective action if possible ! - IF (FAIL) THEN - IF (MYID == 0) WRITE (*, 300) NP(J), NH(J), METHOD(J) - IF (METHOD(J) /= 2) THEN - METHOD(J) = 2 + IF (FAIL) THEN + IF (MYID == 0) WRITE (*, 300) NP(J), NH(J), METHOD(J) + IF (METHOD(J) /= 2) THEN + METHOD(J) = 2 !XHH orthsc does not have any argument ! Orbital J [PF() and QF()]is not updated, why redo orthogonalization - CALL ORTHSC + CALL ORTHSC !CFF ... avoid rediagonalization -! IF (EOL) THEN -! CALL MATRIXMPI -! CALL NEWCOMPI (WTAEV) -! ENDIF - CALL SETLAGmpi (EOL) - GO TO 1 - ELSE - IF (MYID == 0) WRITE (*, 301) +! IF (EOL) THEN +! CALL MATRIXMPI +! CALL NEWCOMPI (WTAEV) +! ENDIF + CALL SETLAGmpi (EOL) + GO TO 1 + ELSE + IF (MYID == 0) WRITE (*, 301) !CALL TIMER (0) - STOP - ENDIF - ENDIF + STOP + ENDIF + ENDIF ! ! Compute norm of radial function ! - TA(1) = 0.D0 - TA(2:MTP0) = (P(2:MTP0)**2+Q(2:MTP0)**2)*RP(2:MTP0) - MTP = MTP0 - - CALL QUAD (DNORM) - + TA(1) = 0.D0 + TA(2:MTP0) = (P(2:MTP0)**2+Q(2:MTP0)**2)*RP(2:MTP0) + MTP = MTP0 + + CALL QUAD (DNORM) + ! Determine self-consistency [multiplied by SQRT(UCF(J))] - - CALL CONSIS (J) + + CALL CONSIS (J) ! ! Normalize ! - DNFAC = 1.D0/DSQRT(DNORM) - P0 = P0*DNFAC - P(:MTP0) = P(:MTP0)*DNFAC - Q(:MTP0) = Q(:MTP0)*DNFAC + DNFAC = 1.D0/DSQRT(DNORM) + P0 = P0*DNFAC + P(:MTP0) = P(:MTP0)*DNFAC + Q(:MTP0) = Q(:MTP0)*DNFAC ! ! Check if different method should be used or if improvement ! count should be reduced ! - DEL1 = DABS(1.D0 - ED2/E(J)) - IF (METHOD(J) == 1) THEN - DEL2 = DMAX1(DABS(1.D0 - DSQRT(DNORM)),DABS(DNFAC - 1.D0)) - IF (DEL1P2) THEN - METHOD(J) = 2 - GO TO 1 - ENDIF - ELSE - IF (DEL11) NSIC = NSIC - 1 - ENDIF + DEL1 = DABS(1.D0 - ED2/E(J)) + IF (METHOD(J) == 1) THEN + DEL2 = DMAX1(DABS(1.D0 - DSQRT(DNORM)),DABS(DNFAC - 1.D0)) + IF (DEL1P2) THEN + METHOD(J) = 2 + GO TO 1 + ENDIF + ELSE + IF (DEL11) NSIC = NSIC - 1 + ENDIF ! ! Damp the orbital --- if not converged ! - IF (SCNSTY(J) > ACCY) THEN - CALL DAMPCK (IPR, J, ED1, ED2) - ODAMPJ = DABS(ODAMP(J)) - ELSE - ODAMPJ = 0.D0 ! take the whole new orbital - ENDIF - CALL DAMPOR (J, INV, ODAMPJ) - + IF (SCNSTY(J) > ACCY) THEN + CALL DAMPCK (IPR, J, ED1, ED2) + ODAMPJ = DABS(ODAMP(J)) + ELSE + ODAMPJ = 0.D0 ! take the whole new orbital + ENDIF + CALL DAMPOR (J, INV, ODAMPJ) + ! Orthogonalize all orbitals of the same kappa in the order ! fixed, spectroscopic, correlation orbitals. The order of ! orbitals in the latter two classes are sorted according ! to their self-consistency and energy. - - IF (ORTHST) THEN + + IF (ORTHST) THEN !CALL orthor (J, inv) - NWWW = NW - CALL ORTHY (NWWW, J, LSORT) - ENDIF + NWWW = NW + CALL ORTHY (NWWW, J, LSORT) + ENDIF ! ! Print details of iteration ! IF (MYID == 0) & WRITE (*, 302) NP(J),NH(J),E(J),METHOD(J),PZ(J),SCNSTY(J), & !cjb DNORM-1 -> SQRT(DNORM)-1 -!cjb DNORM - 1, ODAMPJ, JP, MF(J), INV, NNP +!cjb DNORM - 1, ODAMPJ, JP, MF(J), INV, NNP SQRT(DNORM)-1, ODAMPJ, JP, MF(J), INV, NNP - DAMPMX = DMAX1(DAMPMX,DABS(ODAMPJ)) - + DAMPMX = DMAX1(DAMPMX,DABS(ODAMPJ)) + 300 FORMAT(/,' Failure; equation for orbital ',1I2,1A2,& - ' could not be solved using method ',1I1) + ' could not be solved using method ',1I1) 301 FORMAT(/,/,' ****** Error in SUBROUTINE IMPROV ******'/,& - ' Convergence not obtained'/) + ' Convergence not obtained'/) 302 FORMAT (1X,1I2,1A2,1P,1D16.7,1x,1I2,D11.3,1D10.2,1D10.2,& 0P,F6.3,1x,1I5,1x,1I5,1x,1I2,1x,1I2) - RETURN + RETURN END SUBROUTINE IMPROVmpi diff --git a/src/appl/rmcdhf90_mpi/improvmpi_I.f90 b/src/appl/rmcdhf90_mpi/improvmpi_I.f90 index 5442ca986..58b8c8605 100644 --- a/src/appl/rmcdhf90_mpi/improvmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/improvmpi_I.f90 @@ -1,14 +1,14 @@ - MODULE improvmpi_I + MODULE improvmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:44:01 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:44:01 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE improvmpi (EOL, J, LSORT, DAMPMX) - USE vast_kind_param,ONLY: DOUBLE - LOGICAL, INTENT(IN) :: EOL - INTEGER, INTENT(IN) :: J - LOGICAL :: LSORT - REAL(DOUBLE), INTENT(INOUT) :: DAMPMX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE improvmpi (EOL, J, LSORT, DAMPMX) + USE vast_kind_param,ONLY: DOUBLE + LOGICAL, INTENT(IN) :: EOL + INTEGER, INTENT(IN) :: J + LOGICAL :: LSORT + REAL(DOUBLE), INTENT(INOUT) :: DAMPMX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/in.f90 b/src/appl/rmcdhf90_mpi/in.f90 index 8f6619f51..fe5e888d9 100644 --- a/src/appl/rmcdhf90_mpi/in.f90 +++ b/src/appl/rmcdhf90_mpi/in.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE IN(IORB, JP, P, Q, MTP) + SUBROUTINE IN(IORB, JP, P, Q, MTP) ! * ! This program computes the solution of an inhomogeneous pair of * ! radial Dirac equations in the tail region. A simple extension of * @@ -35,13 +35,13 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) ! Last update: 10 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE def_C, ONLY: accy USE grid_C, ONLY: h, n, r, rpor @@ -50,132 +50,132 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: IORB - INTEGER , INTENT(IN) :: JP - INTEGER , INTENT(OUT) :: MTP - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: IORB + INTEGER , INTENT(IN) :: JP + INTEGER , INTENT(OUT) :: MTP + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, LCNUM, MTPP1 - REAL(DOUBLE), DIMENSION(NNNP) :: TH, TI, TJ, XR, XS + INTEGER :: I, J, LCNUM, MTPP1 + REAL(DOUBLE), DIMENSION(NNNP) :: TH, TI, TJ, XR, XS REAL(DOUBLE) :: EPS, HHK, HHKF, CPJ, CMJ, CPJP1, CMJP1, TEI, TTHIS, TCI, & - TDI, TLAST - CHARACTER :: CNUM*5 + TDI, TLAST + CHARACTER :: CNUM*5 !----------------------------------------------- ! ! Global initializations ! !ww EPS = 0.1D 00*ACCY - EPS = 0.01D00*ACCY - HHK = 0.5D00*H*DBLE(NAK(IORB)) + EPS = 0.01D00*ACCY + HHK = 0.5D00*H*DBLE(NAK(IORB)) ! ! Initialize counters ! - I = 1 - J = JP + I = 1 + J = JP ! ! Other initializations ! - HHKF = HHK*RPOR(J) - CPJ = 1.0D00 + HHKF - CMJ = 1.0D00 - HHKF - HHKF = HHK*RPOR(J+1) - CPJP1 = 1.0D00 + HHKF - CMJP1 = 1.0D00 - HHKF + HHKF = HHK*RPOR(J) + CPJ = 1.0D00 + HHKF + CMJ = 1.0D00 - HHKF + HHKF = HHK*RPOR(J+1) + CPJP1 = 1.0D00 + HHKF + CMJP1 = 1.0D00 - HHKF ! ! Compute required elements of first two rows of L and U ! - TH(I) = CPJ - TEI = -TF(J)/TH(I) - TI(I) = (-CPJP1) + TEI*TG(J+1) - TJ(I) = CMJP1*TEI - TF(J+1) + TH(I) = CPJ + TEI = -TF(J)/TH(I) + TI(I) = (-CPJP1) + TEI*TG(J+1) + TJ(I) = CMJP1*TEI - TF(J+1) ! ! First elements of solution vector Z ! - XR(I) = (-XV(J)) + TG(J)*P(J) - XS(I) = (-XU(J)) - CMJ*P(J) - TEI*XR(I) + XR(I) = (-XV(J)) + TG(J)*P(J) + XS(I) = (-XU(J)) - CMJ*P(J) - TEI*XR(I) ! - TTHIS = ABS(XS(I)/TI(I)) + TTHIS = ABS(XS(I)/TI(I)) ! - 1 CONTINUE - I = I + 1 - J = J + 1 + 1 CONTINUE + I = I + 1 + J = J + 1 ! ! Failure if tables not long enough ! - IF (J >= N) THEN - CALL CONVRT (N, CNUM, LCNUM) - WRITE (6, *) 'IN: maximum tabulation point exceeds' - WRITE (6, *) ' dimensional limit (currently '//CNUM(1:LCNUM)//');' - WRITE (6, *) ' radial wavefunction may indicate a' - WRITE (6, *) ' continuum state.' - STOP - ENDIF + IF (J >= N) THEN + CALL CONVRT (N, CNUM, LCNUM) + WRITE (6, *) 'IN: maximum tabulation point exceeds' + WRITE (6, *) ' dimensional limit (currently '//CNUM(1:LCNUM)//');' + WRITE (6, *) ' radial wavefunction may indicate a' + WRITE (6, *) ' continuum state.' + STOP + ENDIF ! ! Compute required elements of remaining rows of L and U ! - CPJ = CPJP1 - CMJ = CMJP1 - HHKF = HHK*RPOR(J+1) - CPJP1 = 1.0D00 + HHKF - CMJP1 = 1.0D00 - HHKF + CPJ = CPJP1 + CMJ = CMJP1 + HHKF = HHK*RPOR(J+1) + CPJP1 = 1.0D00 + HHKF + CMJP1 = 1.0D00 - HHKF ! - TCI = -TG(J)/TI(I-1) - TH(I) = CPJ - TCI*TJ(I-1) - TDI = CMJ/TI(I-1) - TEI = ((-TF(J))-TDI*TJ(I-1))/TH(I) - TI(I) = (-CPJP1) + TEI*TG(J+1) - TJ(I) = (-TF(J+1)) + CMJP1*TEI + TCI = -TG(J)/TI(I-1) + TH(I) = CPJ - TCI*TJ(I-1) + TDI = CMJ/TI(I-1) + TEI = ((-TF(J))-TDI*TJ(I-1))/TH(I) + TI(I) = (-CPJP1) + TEI*TG(J+1) + TJ(I) = (-TF(J+1)) + CMJP1*TEI ! ! Solution of L*Z = V ! - XR(I) = (-XV(J)) - TCI*XS(I-1) - XS(I) = (-XU(J)) - TDI*XS(I-1) - TEI*XR(I) + XR(I) = (-XV(J)) - TCI*XS(I-1) + XS(I) = (-XU(J)) - TDI*XS(I-1) - TEI*XR(I) ! ! Test for outer boundary ! - TLAST = TTHIS - TTHIS = ABS(XS(I)/TI(I)) - IF (TTHIS + TLAST <= EPS) THEN - MTP = J - ELSE - GO TO 1 - ENDIF + TLAST = TTHIS + TTHIS = ABS(XS(I)/TI(I)) + IF (TTHIS + TLAST <= EPS) THEN + MTP = J + ELSE + GO TO 1 + ENDIF ! ! Reset counter ! - I = I - 1 + I = I - 1 ! ! Last two rows of solution of U*W = Z ; evaluation of Q(J) ! - Q(J) = 0.0D00 - P(J) = XS(I)/TI(I) - Q(J-1) = (XR(I)+TG(J)*P(J))/TH(I) + Q(J) = 0.0D00 + P(J) = XS(I)/TI(I) + Q(J-1) = (XR(I)+TG(J)*P(J))/TH(I) ! ! Solution of U*W = Z ! - 2 CONTINUE - J = J - 1 - I = I - 1 + 2 CONTINUE + J = J - 1 + I = I - 1 ! - IF (I > 0) THEN - P(J) = (XS(I)-TJ(I)*Q(J))/TI(I) - Q(J-1) = (XR(I)+(1.0D00-HHK*RPOR(J))*Q(J)+TG(J)*P(J))/TH(I) - GO TO 2 - ENDIF + IF (I > 0) THEN + P(J) = (XS(I)-TJ(I)*Q(J))/TI(I) + Q(J-1) = (XR(I)+(1.0D00-HHK*RPOR(J))*Q(J)+TG(J)*P(J))/TH(I) + GO TO 2 + ENDIF ! ! Complete tables with zeroes ! - MTPP1 = MTP + 1 - P(MTPP1:N) = 0.0D00 - Q(MTPP1:N) = 0.0D00 + MTPP1 = MTP + 1 + P(MTPP1:N) = 0.0D00 + Q(MTPP1:N) = 0.0D00 ! - RETURN - END SUBROUTINE IN + RETURN + END SUBROUTINE IN diff --git a/src/appl/rmcdhf90_mpi/in_I.f90 b/src/appl/rmcdhf90_mpi/in_I.f90 index aeda6034e..b1661f8ea 100644 --- a/src/appl/rmcdhf90_mpi/in_I.f90 +++ b/src/appl/rmcdhf90_mpi/in_I.f90 @@ -1,16 +1,16 @@ - MODULE in_I + MODULE in_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE in (IORB, JP, P, Q, MTP) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE in (IORB, JP, P, Q, MTP) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - integer, INTENT(IN) :: IORB - integer, INTENT(IN) :: JP - real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q - integer, INTENT(OUT) :: MTP - END SUBROUTINE - END INTERFACE - END MODULE + integer, INTENT(IN) :: IORB + integer, INTENT(IN) :: JP + real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + real(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + integer, INTENT(OUT) :: MTP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/ispar.f90 b/src/appl/rmcdhf90_mpi/ispar.f90 index 93cd281a9..4429c27ab 100644 --- a/src/appl/rmcdhf90_mpi/ispar.f90 +++ b/src/appl/rmcdhf90_mpi/ispar.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ISPAR (ICSF) + INTEGER FUNCTION ISPAR (ICSF) ! * ! ISPAR is the value of P for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ISPAR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA @@ -20,15 +20,15 @@ INTEGER FUNCTION ISPAR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- !----------------------------------------------- ! ispar = jcupa(NNNW,icsf) - IF (ISPAR > 127) ISPAR = ISPAR - 256 - ISPAR = SIGN(1,ISPAR) + IF (ISPAR > 127) ISPAR = ISPAR - 256 + ISPAR = SIGN(1,ISPAR) ! - RETURN - END FUNCTION ISPAR + RETURN + END FUNCTION ISPAR diff --git a/src/appl/rmcdhf90_mpi/ispar_I.f90 b/src/appl/rmcdhf90_mpi/ispar_I.f90 index 41c8e4048..288d27355 100644 --- a/src/appl/rmcdhf90_mpi/ispar_I.f90 +++ b/src/appl/rmcdhf90_mpi/ispar_I.f90 @@ -1,14 +1,14 @@ - MODULE ispar_I + MODULE ispar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ispar (ICSF) - INTEGER, INTENT(IN) :: ICSF + INTEGER FUNCTION ispar (ICSF) + INTEGER, INTENT(IN) :: ICSF !VAST.../ORB2/ NCF(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: JCUPA !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/itjpo.f90 b/src/appl/rmcdhf90_mpi/itjpo.f90 index 941c725f8..355c5744e 100644 --- a/src/appl/rmcdhf90_mpi/itjpo.f90 +++ b/src/appl/rmcdhf90_mpi/itjpo.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITJPO (ICSF) + INTEGER FUNCTION ITJPO (ICSF) ! * ! ITJPO is the value of 2J+1 for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ITJPO (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA @@ -20,10 +20,10 @@ INTEGER FUNCTION ITJPO (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- itjpo = jcupa(NNNW,icsf) - IF (ITJPO > 127) ITJPO = 256 - ITJPO + IF (ITJPO > 127) ITJPO = 256 - ITJPO ITJPO = IABS (ITJPO) - RETURN - END FUNCTION ITJPO + RETURN + END FUNCTION ITJPO diff --git a/src/appl/rmcdhf90_mpi/itjpo_I.f90 b/src/appl/rmcdhf90_mpi/itjpo_I.f90 index 30d3d74e6..0150a4011 100644 --- a/src/appl/rmcdhf90_mpi/itjpo_I.f90 +++ b/src/appl/rmcdhf90_mpi/itjpo_I.f90 @@ -1,14 +1,14 @@ - MODULE itjpo_I + MODULE itjpo_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itjpo (ICSF) - INTEGER, INTENT(IN) :: ICSF + INTEGER FUNCTION itjpo (ICSF) + INTEGER, INTENT(IN) :: ICSF !VAST.../ORB2/ NCF(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: JCUPA !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/lagcon.f90 b/src/appl/rmcdhf90_mpi/lagcon.f90 index d26b1f685..99da51d3c 100644 --- a/src/appl/rmcdhf90_mpi/lagcon.f90 +++ b/src/appl/rmcdhf90_mpi/lagcon.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LAGCON(J, NPROCS) + SUBROUTINE LAGCON(J, NPROCS) ! * ! This routine includes the Lagrange multiplier contribution in * ! the 'exchange' term. * @@ -12,13 +12,13 @@ SUBROUTINE LAGCON(J, NPROCS) ! Modified by Xinghong He Last update: 17 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE def_C USE grid_C @@ -30,57 +30,57 @@ SUBROUTINE LAGCON(J, NPROCS) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J - INTEGER , INTENT(IN) :: NPROCS + INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: NPROCS !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IECCK, L1, L2, M, MFM, I - REAL(DOUBLE) :: EPS, WB, WA, WARI + INTEGER :: K, IECCK, L1, L2, M, MFM, I + REAL(DOUBLE) :: EPS, WB, WA, WARI !----------------------------------------------- ! ! - IF (NEC == 0) RETURN + IF (NEC == 0) RETURN ! !ww EPS = ACCY*0.1D 00 - EPS = ACCY*0.01D00 + EPS = ACCY*0.01D00 ! ! Add contributions from off-diagonal parameters to exchange ! - WB = 1.0D00/(UCF(J)*C)/NPROCS - DO K = 1, NEC + WB = 1.0D00/(UCF(J)*C)/NPROCS + DO K = 1, NEC ! ! Decode index ! - IECCK = IECC(K) - L1 = IECCK/KEY - L2 = IECCK - KEY*L1 + IECCK = IECC(K) + L1 = IECCK/KEY + L2 = IECCK - KEY*L1 ! - IF (J == L1) THEN - M = L2 - ELSE IF (J == L2) THEN - M = L1 - ELSE - CYCLE - ENDIF + IF (J == L1) THEN + M = L2 + ELSE IF (J == L2) THEN + M = L1 + ELSE + CYCLE + ENDIF ! - WA = ECV(K)*WB - IF (ABS(WA) < EPS) CYCLE + WA = ECV(K)*WB + IF (ABS(WA) < EPS) CYCLE ! ! ADD CONTRIBUTIONS TO EXCHANGE TERMS ! - MFM = MF(M) - DO I = 1, MFM - WARI = WA*R(I) - XP(I) = XP(I) + WARI*QF(I,M) - XQ(I) = XQ(I) - WARI*PF(I,M) - END DO + MFM = MF(M) + DO I = 1, MFM + WARI = WA*R(I) + XP(I) = XP(I) + WARI*QF(I,M) + XQ(I) = XQ(I) - WARI*PF(I,M) + END DO ! - END DO + END DO ! - RETURN - END SUBROUTINE LAGCON + RETURN + END SUBROUTINE LAGCON diff --git a/src/appl/rmcdhf90_mpi/lagcon_I.f90 b/src/appl/rmcdhf90_mpi/lagcon_I.f90 index bceed3274..5c5105277 100644 --- a/src/appl/rmcdhf90_mpi/lagcon_I.f90 +++ b/src/appl/rmcdhf90_mpi/lagcon_I.f90 @@ -1,11 +1,11 @@ - MODULE lagcon_I + MODULE lagcon_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lagcon (J, NPROCS) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: NPROCS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lagcon (J, NPROCS) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: NPROCS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/lodcsh2GG.f90 b/src/appl/rmcdhf90_mpi/lodcsh2GG.f90 old mode 100755 new mode 100644 index 29cde3e64..4275ce83e --- a/src/appl/rmcdhf90_mpi/lodcsh2GG.f90 +++ b/src/appl/rmcdhf90_mpi/lodcsh2GG.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) + SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! ! IMPORTANT: ! ========== @@ -30,73 +30,73 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! JCUPA(NNNW*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C + USE DEBUG_C + USE DEF_C USE ORB_C, ncfblock => ncf USE SYMA_C, ONLY: JPGG - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrcn_I - USE parsjl_I + USE prsrcn_I + USE parsjl_I USE pack_I - USE convrt_I - USE iq_I - USE jqs_I - USE jcup_I + USE convrt_I + USE iq_I + USE jqs_I + USE jcup_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER :: NCORE - INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NFILE + INTEGER :: NCORE + INTEGER, INTENT(IN) :: JB !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: LOADALL = -119 - CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: LOADALL = -119 + CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER, DIMENSION(NW2) :: IQSUB - INTEGER, DIMENSION(NNNW) :: JX + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER, DIMENSION(NW2) :: IQSUB + INTEGER, DIMENSION(NNNW) :: JX INTEGER :: NCORP1, NREC, NCF, NPEEL, I, J INTEGER :: IOS, IERR, LOC, NQS, ISPARC, NJX, IOC, IPTY INTEGER :: NQSN, NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI INTEGER :: NKJI, IFULLI, NU, JSUB, IQT, NBEG, NEND INTEGER :: LENTH, JXN, JPI, NCOREL, IQGG, JBGG, NCFGG - LOGICAL :: EMPTY, FULL - CHARACTER :: STR*256, RECL + LOGICAL :: EMPTY, FULL + CHARACTER :: STR*256, RECL !----------------------------------------------- ! - IF (JB /= LOADALL) THEN - WRITE (6, *) 'Loading CSF File for block ', JB - ELSE - WRITE (6, *) 'Loading CSF File for ALL blocks ' - ENDIF - - NCORP1 = NCORE + 1 - NPEEL = NW - NCORE + IF (JB /= LOADALL) THEN + WRITE (6, *) 'Loading CSF File for block ', JB + ELSE + WRITE (6, *) 'Loading CSF File for ALL blocks ' + ENDIF + + NCORP1 = NCORE + 1 + NPEEL = NW - NCORE ! ! NPEEL is used as 1) number of peel orbitals (here) and ! 2) number of peel electrons (later in this routine) ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -106,13 +106,13 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) ! ! Zero out the arrays that store packed integers - only when ncfblock>0 ! - IQA(:NNNW,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,1,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,2,:NCFBLOCK) = 0 -!GG JQSA(:NNNW,3,:NCFBLOCK) = 0 -!GG JCUPA(:NNNW,:NCFBLOCK) = 0 - - NCF = 0 + IQA(:NNNW,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,1,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,2,:NCFBLOCK) = 0 +!GG JQSA(:NNNW,3,:NCFBLOCK) = 0 +!GG JCUPA(:NNNW,:NCFBLOCK) = 0 + + NCF = 0 !GGGG NCFGG = 0 JBGG = 1 @@ -122,8 +122,8 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) !GG NCF = NCF + 1 !GGGG ! - READ (NFILE, '(A)', IOSTAT=IOS) STR - + READ (NFILE, '(A)', IOSTAT=IOS) STR + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This IF...READ makes the routine load the entire file (all blocks) ! by ignoring the end-of-block mark @@ -137,342 +137,342 @@ SUBROUTINE LODCSH2GG(NFILE, NCORE, JB) NCFGG = 1 JBGG = JBGG + 1 END IF -!GGGG +!GGGG !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (IOS==0 .AND. STR(1:2)/=' *') THEN + + IF (IOS==0 .AND. STR(1:2)/=' *') THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (STR, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 28 + CALL PRSRCN (STR, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 28 ! ! Read the J_sub and v quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting subshell quantum', & - ' number specification;' - GO TO 27 - ENDIF - LOC = LEN_TRIM(STR) - CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 27 + ' number specification;' + GO TO 27 + ENDIF + LOC = LEN_TRIM(STR) + CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 27 ! ! Read the X, J, and (sign of) P quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Zero out the arrays that store packed integers ! - IQA(:NNNW,NCF) = 0 -!GG JQSA(:NNNW,1,NCF) = 0 -!GG JQSA(:NNNW,2,NCF) = 0 -!GG JQSA(:NNNW,3,NCF) = 0 -!GG JCUPA(:NNNW,NCF) = 0 + IQA(:NNNW,NCF) = 0 +!GG JQSA(:NNNW,1,NCF) = 0 +!GG JQSA(:NNNW,2,NCF) = 0 +!GG JQSA(:NNNW,3,NCF) = 0 +!GG JCUPA(:NNNW,NCF) = 0 ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - LOC = LEN_TRIM(STR) - RECL = STR(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + LOC = LEN_TRIM(STR) + RECL = STR(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) MYNAME//': Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) -!GG CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) +!GG CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': Subshell quantum numbers ', & 'specified incorrectly for '//STR(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) MYNAME//': Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': coupling of '//STR(1:LENTH)//& - NH(I), ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE -!GG CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) -!GG CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) -!GG CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! -!GG DO I = MAX(1,NOPEN), NW -!GG CALL PACK (0, I, JCUPA(1:NNNW,NCF)) -!GG END DO -! - IF (NQSN /= NQS) THEN + NH(I), ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE +!GG CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) +!GG CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) +!GG CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! +!GG DO I = MAX(1,NOPEN), NW +!GG CALL PACK (0, I, JCUPA(1:NNNW,NCF)) +!GG END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) MYNAME//': Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) MYNAME//': Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) MYNAME//': Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY + JPI = (JLAST + 1)*IPTY !GGGG IF(NCFGG .EQ. 1) THEN JPGG(JBGG) = JPI END IF -!GG CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) +!GG CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) !GGGG ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) MYNAME//': Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! -!GG IF (NCF > 1) THEN -!GG DO J = 1, NCF - 1 -!GG DO I = NCORP1, NW -!GG IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 -!GG IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 -!GG IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 -!GG IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 -!GG END DO -!GG DO I = 1, NOPEN - 1 -!GG IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 -!GG END DO -!GG END DO -!GG WRITE (ISTDE, *) MYNAME//': Repeated CSF;' -!GG GO TO 26 -!GG ENDIF +!GG IF (NCF > 1) THEN +!GG DO J = 1, NCF - 1 +!GG DO I = NCORP1, NW +!GG IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 +!GG IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 +!GG IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 +!GG IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 +!GG END DO +!GG DO I = 1, NOPEN - 1 +!GG IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 +!GG END DO +!GG END DO +!GG WRITE (ISTDE, *) MYNAME//': Repeated CSF;' +!GG GO TO 26 +!GG ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + + GO TO 3 ! - ELSE ! the record just read is either ' *' or EOF, marking + ELSE ! the record just read is either ' *' or EOF, marking ! the end of a block or end of the file ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) -!GG CALL PACK (0, I, JQSA(1:NNNW,1,1)) -!GG CALL PACK (0, I, JQSA(1:NNNW,2,1)) -!GG CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO -!GG CALL PACK (0, 1, JCUPA(1:NNNW,1)) -!GG CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF - - IF (NCF /= NCFBLOCK) THEN - WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK - STOP - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) +!GG CALL PACK (0, I, JQSA(1:NNNW,1,1)) +!GG CALL PACK (0, I, JQSA(1:NNNW,2,1)) +!GG CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO +!GG CALL PACK (0, 1, JCUPA(1:NNNW,1)) +!GG CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF + + IF (NCF /= NCFBLOCK) THEN + WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK + STOP + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), STR, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (6, *) 'Subshell '//STR(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs' - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ' in all CSFs' + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! This will act as a check now - it's been determined in lodcsh ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) ! NELEC = NCOREL+NPEEL - IF (NCOREL + NPEEL /= NELEC) THEN - WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' - STOP - ENDIF + IF (NCOREL + NPEEL /= NELEC) THEN + WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' + STOP + ENDIF WRITE (6,*)'There are ',NCF,' relativistic CSFs... load complete;' - RETURN -! - 26 CONTINUE - BACKSPACE (NFILE) - 27 CONTINUE - BACKSPACE (NFILE) - 28 CONTINUE - BACKSPACE (NFILE) - WRITE (ISTDE, *) ' CSF sequence number: ', NCF - DO I = 1, 3 + RETURN +! + 26 CONTINUE + BACKSPACE (NFILE) + 27 CONTINUE + BACKSPACE (NFILE) + 28 CONTINUE + BACKSPACE (NFILE) + WRITE (ISTDE, *) ' CSF sequence number: ', NCF + DO I = 1, 3 READ (nfile,'(A)',ERR = 29,END = 29) str - WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) - END DO + WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) + END DO 29 continue - CLOSE(NFILE) - - STOP + CLOSE(NFILE) + + STOP END SUBROUTINE LODCSH2GG diff --git a/src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 b/src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 old mode 100755 new mode 100644 index 58158ef85..c503c1486 --- a/src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 +++ b/src/appl/rmcdhf90_mpi/lodcsh2GG_I.f90 @@ -1,12 +1,12 @@ - MODULE lodcsh2GG_I + MODULE lodcsh2GG_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcsh2GG(NFILE, NCORE, JB) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(OUT) :: NCORE + SUBROUTINE lodcsh2GG(NFILE, NCORE, JB) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(OUT) :: NCORE INTEGER, INTENT(IN) :: JB - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/lodcslmpiGG.f90 b/src/appl/rmcdhf90_mpi/lodcslmpiGG.f90 index 0e26bc214..422d8ddc8 100644 --- a/src/appl/rmcdhf90_mpi/lodcslmpiGG.f90 +++ b/src/appl/rmcdhf90_mpi/lodcslmpiGG.f90 @@ -1,29 +1,29 @@ !*********************************************************************** SUBROUTINE lodcslmpiGG (nfile, ncore, jblock) -! An MPI container of lodcsh2 which loads CSL list of the current block -! into memory. It forwards the call together with the same set of +! An MPI container of lodcsh2 which loads CSL list of the current block +! into memory. It forwards the call together with the same set of ! parameters to lodcsh2 and then broadcasts the results to all nodes. ! ! Note: Memories have been allocated/deallocated each block outside. -! This subroutine calls lodcsh2 on node-0 to generate the data for the +! This subroutine calls lodcsh2 on node-0 to generate the data for the ! block; and then broadcasts to all other nodes. A new MPI data type ! of 4 byte-long is created to handle 64-bit machines whose MPI ! implementation does not support 4-byte integers. If jblock=-119, -! then ALL blocks will be loaded instead of just one. This is +! then ALL blocks will be loaded instead of just one. This is ! implemented in lodcsh2. ! -! Currently used by rcimpivu, mcpmpi, rscfmpivu +! Currently used by rcimpivu, mcpmpi, rscfmpivu ! ! Xinghong He 98-08-06 ! !*********************************************************************** -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: BYTE USE parameter_def, ONLY: NNNW diff --git a/src/appl/rmcdhf90_mpi/lodcslmpiGG_I.f90 b/src/appl/rmcdhf90_mpi/lodcslmpiGG_I.f90 index 1eb88392b..311fa8ec9 100644 --- a/src/appl/rmcdhf90_mpi/lodcslmpiGG_I.f90 +++ b/src/appl/rmcdhf90_mpi/lodcslmpiGG_I.f90 @@ -1,7 +1,7 @@ MODULE lodcslmpiGG_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE lodcslmpiGG (nfile, ncore, jblock) INTEGER :: nfile, ncore, jblock diff --git a/src/appl/rmcdhf90_mpi/maneigmpi.f90 b/src/appl/rmcdhf90_mpi/maneigmpi.f90 index 84030e8c7..afa217d0e 100644 --- a/src/appl/rmcdhf90_mpi/maneigmpi.f90 +++ b/src/appl/rmcdhf90_mpi/maneigmpi.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE MANEIGmpi(dvdfirst, LPRINT, JBLOCK, & - NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) ! * ! This module manages the operation of the eigensolvers and the * ! storage of the eigenpairs. There are two principal branches: * @@ -32,67 +32,67 @@ SUBROUTINE MANEIGmpi(dvdfirst, LPRINT, JBLOCK, & ! JCUPA(NNNWP*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE DEF_C + USE DEF_C USE eigv_C USE hblock_C USE hmat_C USE mpi_C USE orb_C USE symA_C, ONLY: JPGG - USE WCHBLK_C, JBLOCKK=>JBLOCK - USE WHERE_C + USE WCHBLK_C, JBLOCKK=>JBLOCK + USE WHERE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE spicmvmpi_I - USE iniestmpi_I - USE gdvd_I - USE itjpo_I - USE ispar_I + USE spicmvmpi_I + USE iniestmpi_I + USE gdvd_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- logical, INTENT(IN) :: dvdfirst - INTEGER :: JBLOCK - INTEGER, INTENT(IN) :: NCFPAT - INTEGER, INTENT(IN) :: NCMINPAT - INTEGER, INTENT(IN) :: NEVECPAT - INTEGER :: NCFTOT - LOGICAL :: LPRINT + INTEGER :: JBLOCK + INTEGER, INTENT(IN) :: NCFPAT + INTEGER, INTENT(IN) :: NCMINPAT + INTEGER, INTENT(IN) :: NEVECPAT + INTEGER :: NCFTOT + LOGICAL :: LPRINT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NVECT, LIM, LWORK, NVEX, NIV, MAXITR, N1000, MBLOCK, & ILOW, IHIGH, LIWORK, IC, NLOOPS, NMV, NEND, J, JSTATE, & - IOFSET, I, IA + IOFSET, I, IA INTEGER, DIMENSION(:), POINTER :: IWORK, JWORK - REAL(DOUBLE) :: PNWORK, CRITE, CRITC, CRITR, ORTHO, AMAX, WA, DNFAC + REAL(DOUBLE) :: PNWORK, CRITE, CRITC, CRITR, ORTHO, AMAX, WA, DNFAC REAL(DOUBLE), DIMENSION(:), POINTER :: WORK, DIAG, atmp - LOGICAL :: HIEND + LOGICAL :: HIEND !----------------------------------------------- !PRINT *, 'maneig ...' - + ! ...spicmvmpi needs this COMMON /WCHBLK/JBLOCKK - JBLOCKK = JBLOCK + JBLOCKK = JBLOCK ! !======================================================================= ! Trivial case !======================================================================= - IF (NCF == 1) THEN - EVAL(NCMINPAT+1) = 0.D0 - EVEC(NEVECPAT+1) = 1.D0 - GO TO 123 ! Don't like big ELSE - ENDIF + IF (NCF == 1) THEN + EVAL(NCMINPAT+1) = 0.D0 + EVEC(NEVECPAT+1) = 1.D0 + GO TO 123 ! Don't like big ELSE + ENDIF ! !======================================================================= ! Non-trivial case - Use Davidson eigensolver @@ -102,27 +102,27 @@ SUBROUTINE MANEIGmpi(dvdfirst, LPRINT, JBLOCK, & ! the expression below; the value of LIM can be reduced to NVECT ! plus a smaller number if storage is severely constrained ! - NVECT = NCMAXBLK(JBLOCK) + NVECT = NCMAXBLK(JBLOCK) !CFF ... make this more like rscf lim = MIN (ncf, 2*nvect + 80) !GG lim = MIN (ncf, 2*nvect + 40) -! LIM = MIN(NCF,2*NVECT + 20) - LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECT - CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIGmpi') - +! LIM = MIN(NCF,2*NVECT + 20) + LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECT + CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIGmpi') + !...At most 14 ? restriction removed xhh 98-05-19 !nvex = MIN (nvect,ncfblk(jblock),14) - NVEX = MIN(NVECT,NCFBLK(JBLOCK)) - NIV = NVEX - MAXITR = MIN(NVECT*200,NCF) -! N1000 = 2000 - N1000 = 4000 + NVEX = MIN(NVECT,NCFBLK(JBLOCK)) + NIV = NVEX + MAXITR = MIN(NVECT*200,NCF) +! N1000 = 2000 + N1000 = 4000 ! ! Initial estimates for eigenvectors ! !CFF if (dvdfirst .or. (ncf .LE. n1000) ) then -!GG CALL INIESTmpi (N1000, NCF, NIV, WORK, EMT, IENDC, IROW) +!GG CALL INIESTmpi (N1000, NCF, NIV, WORK, EMT, IENDC, IROW) CALL INIESTmpi (N1000, NCF, NIV, WORK, EMT, IENDC(0:NCF), IROW) else !CFF .. use current estimates @@ -133,114 +133,114 @@ SUBROUTINE MANEIGmpi(dvdfirst, LPRINT, JBLOCK, & work( ncf*(iccmin(j+ncminpat)-1) + 1 ), 1) ENDDO ENDIF - + ! iniest looks for eigenvectors of n1000*n1000 matrix so there ! is no need to call dvdson if block size <= n1000 - - IF (NCF > N1000) THEN + + IF (NCF > N1000) THEN IF (myid == 0) WRITE (*,*) 'Calling dvdson!!!', maxitr,nvect - + ! Call Davidson eigensolver - - MBLOCK = 1 - ILOW = 1 - IHIGH = NVEX - LIWORK = 6*LIM + NVECT - CRITE = 1.0D-17 -! CRITC = 1.0D-08 -! CRITR = 1.0D-08 -! ORTHO = MAX(1D-8,CRITR) + + MBLOCK = 1 + ILOW = 1 + IHIGH = NVEX + LIWORK = 6*LIM + NVECT + CRITE = 1.0D-17 +! CRITC = 1.0D-08 +! CRITR = 1.0D-08 +! ORTHO = MAX(1D-8,CRITR) critc = 1.0D-09 critr = 1.0D-09 ortho = MAX (1D-9, critr) ! ! Store the diagonals in a separate array and make it global ! - CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIGmpi') - CALL ALLOC (atmp, NCF, 'ATMP', 'MANEIGmpi') + CALL ALLOC (DIAG, NCF, 'DIAG', 'MANEIGmpi') + CALL ALLOC (atmp, NCF, 'ATMP', 'MANEIGmpi') DO i = 1, ncf atmp(i) = 0.D0 diag(i) = 0.D0 ! this one may not be necessary ENDDO - - DO IC = MYID + 1, NCF, NPROCS -!GG DIAG(IC) = EMT(IENDC(IC)) + + DO IC = MYID + 1, NCF, NPROCS +!GG DIAG(IC) = EMT(IENDC(IC)) atmp(ic) = emt(iendc(ic)) - END DO + END DO CALL MPI_Allreduce (atmp, diag, ncf, MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) CALL DALLOC(atmp,'ATMP', 'MANEIGmpi') - - CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIGmpi') - CALL ALLOC (JWORK, LIM, 'JWORK', 'MANEIGmpi') + + CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIGmpi') + CALL ALLOC (JWORK, LIM, 'JWORK', 'MANEIGmpi') if (ncf.gt.1000) then CALL GDVD (SPICMVMPI,NCF,LIM,DIAG,ILOW,IHIGH,JWORK,NIV,MBLOCK, & CRITE, CRITC, CRITR, ORTHO, MAXITR, WORK, LWORK, IWORK, LIWORK, & - HIEND, NLOOPS, NMV, IERR) + HIEND, NLOOPS, NMV, IERR) end if - CALL DALLOC (DIAG, 'DIAG', 'MANEIGmpi') - CALL DALLOC (IWORK, 'IWORK', 'MANEIGmpi') - CALL DALLOC (JWORK, 'JWORK', 'MANEIGmpi') + CALL DALLOC (DIAG, 'DIAG', 'MANEIGmpi') + CALL DALLOC (IWORK, 'IWORK', 'MANEIGmpi') + CALL DALLOC (JWORK, 'JWORK', 'MANEIGmpi') IF (myid .EQ. 0) THEN WRITE (*,301) nloops, nmv IF (ierr .NE. 0) THEN WRITE (*,302) ierr ENDIF - ENDIF - ENDIF + ENDIF + ENDIF ! ! Pick up the eigen pairs and store in EVAL and EVEC ! - NEND = NCF*NVEX - DO J = 1, NEVBLK(JBLOCK) - EVAL(NCMINPAT+J) = WORK(NEND + ICCMIN(J + NCMINPAT)) + NEND = NCF*NVEX + DO J = 1, NEVBLK(JBLOCK) + EVAL(NCMINPAT+J) = WORK(NEND + ICCMIN(J + NCMINPAT)) CALL DCOPY (NCF, WORK(NCF*(ICCMIN(J + NCMINPAT) - 1) + 1), 1, EVEC(& - NEVECPAT+NCF*(J-1)+1), 1) - END DO + NEVECPAT+NCF*(J-1)+1), 1) + END DO ! print *, ncminpat,(eval(ncminpat+j),j=1,nevblk(jblock)), ! 1 'zou,from maneig' ! ! Deallocate storage ! - CALL DALLOC (WORK, 'WORK', 'MANEIGmpi') - - 123 CONTINUE - DO JSTATE = 1, NEVBLK(JBLOCK) + CALL DALLOC (WORK, 'WORK', 'MANEIGmpi') + + 123 CONTINUE + DO JSTATE = 1, NEVBLK(JBLOCK) ! ! Find the dominant component of each eigenvector ! - IOFSET = NEVECPAT + NCF*(JSTATE - 1) - - AMAX = 0.D0 - DO I = 1, NCF - WA = ABS(EVEC(I+IOFSET)) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO + IOFSET = NEVECPAT + NCF*(JSTATE - 1) + + AMAX = 0.D0 + DO I = 1, NCF + WA = ABS(EVEC(I+IOFSET)) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO ! ! Find the angular momentum and parity of the dominant component ! -!GG IATJPO(JSTATE+NCMINPAT) = ITJPO(IA + NCFPAT) -!GG IASPAR(JSTATE+NCMINPAT) = ISPAR(IA + NCFPAT) +!GG IATJPO(JSTATE+NCMINPAT) = ITJPO(IA + NCFPAT) +!GG IASPAR(JSTATE+NCMINPAT) = ISPAR(IA + NCFPAT) ! ! Redefine eigenvectors so that the dominant component ! is positive ! - IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE - DNFAC = -1.D0 - CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) + IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE + DNFAC = -1.D0 + CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) !=============================================================== - - END DO - - 301 FORMAT('DVDSON: ',1I3,' loops; ',1I3,' matrix-vector multiplies.') - 302 FORMAT(' Returned from DVDSON with IERR = ',1I4) + + END DO + + 301 FORMAT('DVDSON: ',1I3,' loops; ',1I3,' matrix-vector multiplies.') + 302 FORMAT(' Returned from DVDSON with IERR = ',1I4) 303 FORMAT(/,' ***** WARNING *****'/,/,& ' The angular momentum and parity of level ',1I2,' have changed:'/,& ' Last iteration: (2J+1) = ',1I2,', parity = ',1I2,';'/,& - ' this iteration: (2J+1) = ',1I2,', parity = ',1I2,'.') - - RETURN + ' this iteration: (2J+1) = ',1I2,', parity = ',1I2,'.') + + RETURN END SUBROUTINE MANEIGmpi diff --git a/src/appl/rmcdhf90_mpi/maneigmpi_I.f90 b/src/appl/rmcdhf90_mpi/maneigmpi_I.f90 index a07bb2734..39a7fcbc2 100644 --- a/src/appl/rmcdhf90_mpi/maneigmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/maneigmpi_I.f90 @@ -1,17 +1,17 @@ - MODULE maneigmpi_I + MODULE maneigmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:49:56 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:49:56 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maneigmpi (dvdfirst,LPRINT, JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + SUBROUTINE maneigmpi (dvdfirst,LPRINT, JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) logical, INTENT(IN) :: dvdfirst - LOGICAL :: LPRINT + LOGICAL :: LPRINT !VAST...Dummy argument LPRINT is not referenced in this routine. - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: NCFPAT - INTEGER, INTENT(IN) :: NCMINPAT - INTEGER, INTENT(IN) :: NEVECPAT - INTEGER :: NCFTOT - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: NCFPAT + INTEGER, INTENT(IN) :: NCMINPAT + INTEGER, INTENT(IN) :: NEVECPAT + INTEGER :: NCFTOT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/matrixmpi.f90 b/src/appl/rmcdhf90_mpi/matrixmpi.f90 index 13a6b4c21..bb50dc2c8 100644 --- a/src/appl/rmcdhf90_mpi/matrixmpi.f90 +++ b/src/appl/rmcdhf90_mpi/matrixmpi.f90 @@ -15,22 +15,22 @@ SUBROUTINE MATRIXmpi(dvdfirst) ! Block version by Xinghong He 07 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE damp_C USE def_C, ONLY: iccmin, ncmin, ncmax - USE DEBUG_C + USE DEBUG_C USE eigv_C USE hblock_C USE hmat_C USE iounit_C - USE MCPA_C + USE MCPA_C USE mpi_C USE orb_C USE pos_C @@ -39,8 +39,8 @@ SUBROUTINE MATRIXmpi(dvdfirst) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setham_I - USE maneigmpi_I + USE setham_I + USE maneigmpi_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -55,220 +55,220 @@ SUBROUTINE MATRIXmpi(dvdfirst) REAL(DOUBLE), DIMENSION(:), POINTER :: CMVL REAL(DOUBLE) :: amax, cdampj, dnfac, evecij, sum, tmp, omcdaj, ovrlap, wa INTEGER, EXTERNAL :: ddot - LOGICAL :: FIRST - CHARACTER :: MCPLAB*3 + LOGICAL :: FIRST + CHARACTER :: MCPLAB*3 - SAVE FIRST + SAVE FIRST ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! POINTER (cmvl(1)) ! !----------------------------------------------------------------------- - - IF (MYID == 0) WRITE (6, *) - + + IF (MYID == 0) WRITE (6, *) + ! Allocate memory for CMVL once (the maximum size) ! Save previous estimate of eigenvectors - - IF (.NOT.FIRST) THEN - CALL ALLOC (CMVL, NVECSIZ, 'CMVL', 'MATRIXmpi') - CALL DCOPY (NVECSIZ, EVEC, 1, CMVL, 1) - ENDIF - + + IF (.NOT.FIRST) THEN + CALL ALLOC (CMVL, NVECSIZ, 'CMVL', 'MATRIXmpi') + CALL DCOPY (NVECSIZ, EVEC, 1, CMVL, 1) + ENDIF + !======================================================================= ! Position the files - MCP files (unit NFILE) for reading ! and mixing coefficients file (unit 25) for writing !======================================================================= - - DO NFILE = 30, 32 + KMAXF - REWIND (NFILE) - IF (NFILE == 30) THEN - READ (NFILE) - READ (NFILE) - READ (NFILE) - ENDIF - READ (NFILE) - READ (NFILE) - READ (NFILE) - END DO - + + DO NFILE = 30, 32 + KMAXF + REWIND (NFILE) + IF (NFILE == 30) THEN + READ (NFILE) + READ (NFILE) + READ (NFILE) + ENDIF + READ (NFILE) + READ (NFILE) + READ (NFILE) + END DO + ! To put in ncmin and nvecsiz. Values read here are the same ! as those from elsewhere (shch as common blocks) - IF (MYID == 0) THEN - REWIND (25) - READ (25) ! 'G92MIX' - READ (25) NELEC, NCFTOT, NW, NTMP, NTMP, NBLOCK - BACKSPACE (25) - WRITE (25) NELEC, NCFTOT, NW, NCMIN, NVECSIZ, NBLOCK - ENDIF - + IF (MYID == 0) THEN + REWIND (25) + READ (25) ! 'G92MIX' + READ (25) NELEC, NCFTOT, NW, NTMP, NTMP, NBLOCK + BACKSPACE (25) + WRITE (25) NELEC, NCFTOT, NW, NCMIN, NVECSIZ, NBLOCK + ENDIF + !======================================================================= ! Do the job block by block !======================================================================= - + !------------------------------------------------ - DO JBLOCK = 1, NBLOCK ! block do-loop + DO JBLOCK = 1, NBLOCK ! block do-loop !------------------------------------------------ - + !======================================================================= ! Read indeces of non-zero elements from mcp.30 file. Note the ! format has been changed to lower-triangle-by-rows. ! Length of iendc can be reduced !======================================================================= - - READ (30) MCPLAB, JBLOCKT, NCF + + READ (30) MCPLAB, JBLOCKT, NCF IF (JBLOCKT/=JBLOCK .OR. NCF/=NCFBLK(JBLOCK)) STOP & - 'MATRIXMPI: jblockt .NE. jblock .OR. ncf1 .NE. ncf2' + 'MATRIXMPI: jblockt .NE. jblock .OR. ncf1 .NE. ncf2' READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'MATRIXmpi') - CALL ALLOC (EMT, NELMNT, 'EMT', 'MATRIXmpi') - CALL ALLOC (IENDC, NCF + 1, 'IENDC', 'MATRIXMPI' ) - + CALL ALLOC (IROW, NELMNT, 'IROW', 'MATRIXmpi') + CALL ALLOC (EMT, NELMNT, 'EMT', 'MATRIXmpi') + CALL ALLOC (IENDC, NCF + 1, 'IENDC', 'MATRIXMPI' ) + ! ! may not be necessary if iendc is ALWAYS used -!GG IENDC(:NCF) = 0 ! the way it is assigned here. +!GG IENDC(:NCF) = 0 ! the way it is assigned here. IENDC(0:NCF) = 0 - + !...EMT will be accumulated in setham - EMT(:NELMNT) = 0.D0 - - READ (30) (IENDC(I),I=MYID+1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - - NCFPAT = NCFPAST(JBLOCK) - NCMINPAT = NCMINPAST(JBLOCK) - NEVECPAT = NEVECPAST(JBLOCK) - + EMT(:NELMNT) = 0.D0 + + READ (30) (IENDC(I),I=MYID+1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + + NCFPAT = NCFPAST(JBLOCK) + NCMINPAT = NCMINPAST(JBLOCK) + NEVECPAT = NEVECPAST(JBLOCK) + !======================================================================= ! Skip current block if no eigenlaue is required !======================================================================= - - IF (NEVBLK(JBLOCK) == 0) THEN - DO NFILE = 31, 32 + KMAXF - READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF + + IF (NEVBLK(JBLOCK) == 0) THEN + DO NFILE = 31, 32 + KMAXF + READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF IF (JBLOCKT /= JBLOCK) & - STOP 'MATRIXmpi: jblockt .NE. jblock' - IF (NCFT /= NCF) STOP 'MATRIXmpi: ncft .NE. ncf' - - READ (NFILE) LAB, NCONTR - DO WHILE(LAB/=0 .OR. NCONTR/=0) - READ (NFILE) (ITMP,ITMP,TMP,I=1,NCONTR) - READ (NFILE) LAB, NCONTR - END DO - END DO - - CALL DALLOC (IENDC, 'IENDC', 'MATRIXmpi') - CALL DALLOC (IROW, 'IROW', 'MATRIXmpi') - - CYCLE - - ENDIF - + STOP 'MATRIXmpi: jblockt .NE. jblock' + IF (NCFT /= NCF) STOP 'MATRIXmpi: ncft .NE. ncf' + + READ (NFILE) LAB, NCONTR + DO WHILE(LAB/=0 .OR. NCONTR/=0) + READ (NFILE) (ITMP,ITMP,TMP,I=1,NCONTR) + READ (NFILE) LAB, NCONTR + END DO + END DO + + CALL DALLOC (IENDC, 'IENDC', 'MATRIXmpi') + CALL DALLOC (IROW, 'IROW', 'MATRIXmpi') + + CYCLE + + ENDIF + !======================================================================= ! Generate the Hamiltonian matrix - average energy is removed here !======================================================================= - - CALL SETHAM (JBLOCK, MYID, NPROCS) + + CALL SETHAM (JBLOCK, MYID, NPROCS) ! ! Determine average energy ! - EAV = 0.D0 + EAV = 0.D0 DO IR = myid + 1, ncf, nprocs - EAV = EAV + EMT(IENDC(IR)) + EAV = EAV + EMT(IENDC(IR)) END DO call MPI_BARRIER(MPI_COMM_WORLD,ierr) CALL MPI_Allreduce (eav,tmp,1,MPI_DOUBLE_PRECISION,MPI_SUM, & MPI_COMM_WORLD,ierr) eav = tmp / ncf -!GG EAV = EAV/NCF - EAVBLK(JBLOCK) = EAV - +!GG EAV = EAV/NCF + EAVBLK(JBLOCK) = EAV + ! Print Hamiltonian matrix and average energy ! hmout is not general !call hmout (0, 1, ncf) - - IF (MYID == 0) WRITE (*, 302) EAV - + + IF (MYID == 0) WRITE (*, 302) EAV + ! Subtract the average energy from the diagonal elements ! to reduce the condition number of the matrix -! DO I = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS +! DO I = 1, (NCF - (MYID + 1) + NPROCS)/NPROCS ! EMT(IENDC(NPROCS*(I-1)+MYID+1)) = EMT(IENDC(NPROCS*(I-1)+MYID+1))& -! - EAV +! - EAV DO i = myid + 1, ncf, nprocs idiag = iendc(i) ! new mode: each row ends in diagonal emt(idiag) = emt(idiag) - eav - END DO - + END DO + !======================================================================= ! Compute and store eigenpairs !======================================================================= CALL MANEIGmpi (dvdfirst, LDBPG(3), & - JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) - + JBLOCK, NCFPAT, NCMINPAT, NEVECPAT, NCFTOT) + !======================================================================= ! Damp and Schmidt orthogonalise eigenvectors for OL calculations !======================================================================= - - IF (.NOT.FIRST) THEN - - DO J = 1, NEVBLK(JBLOCK) - - IOFSET = (J - 1)*NCF + NEVECPAT - JOTHER = J - + + IF (.NOT.FIRST) THEN + + DO J = 1, NEVBLK(JBLOCK) + + IOFSET = (J - 1)*NCF + NEVECPAT + JOTHER = J + ! cdamp has the original non-block feature - CDAMPJ = CDAMP(J + NCMINPAT) - IF (CDAMPJ == 0.D0) CYCLE ! So SURE ??? - - OMCDAJ = 1.D0 - CDAMPJ - + CDAMPJ = CDAMP(J + NCMINPAT) + IF (CDAMPJ == 0.D0) CYCLE ! So SURE ??? + + OMCDAJ = 1.D0 - CDAMPJ + !...Damp eigenvector and determine the new dominant component - 123 CONTINUE - AMAX = 0.D0 - DO I = 1, NCF - EVECIJ = OMCDAJ*EVEC(I+IOFSET) + CDAMPJ*CMVL(I + IOFSET) - EVEC(I+IOFSET) = EVECIJ - WA = ABS(EVECIJ) - IF (WA <= AMAX) CYCLE - AMAX = WA - IA = I - END DO - + 123 CONTINUE + AMAX = 0.D0 + DO I = 1, NCF + EVECIJ = OMCDAJ*EVEC(I+IOFSET) + CDAMPJ*CMVL(I + IOFSET) + EVEC(I+IOFSET) = EVECIJ + WA = ABS(EVECIJ) + IF (WA <= AMAX) CYCLE + AMAX = WA + IA = I + END DO + !...compute the normalization factor - SUM = 0.D0 - DO I = 1, NCF - SUM = SUM + EVEC(I+IOFSET)**2 - END DO - DNFAC = 1.D0/SQRT(SUM) - + SUM = 0.D0 + DO I = 1, NCF + SUM = SUM + EVEC(I+IOFSET)**2 + END DO + DNFAC = 1.D0/SQRT(SUM) + !...Renormalize and invert as necessary - IF (EVEC(IA+IOFSET) < 0.D0) DNFAC = -DNFAC - CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) - + IF (EVEC(IA+IOFSET) < 0.D0) DNFAC = -DNFAC + CALL DSCAL (NCF, DNFAC, EVEC(IOFSET+1), 1) + !...Schmidt orthogonalise - 234 CONTINUE - JOTHER = JOTHER - 1 - IF (JOTHER < 1) CYCLE - JOFSET = (JOTHER - 1)*NCF + NEVECPAT - OVRLAP = DDOT(NCF,EVEC(IOFSET+1),1,EVEC(JOFSET+1),1) - IF (OVRLAP /= 0.D0) THEN ! So SURE ??? - OMCDAJ = 1.D0 - CDAMPJ = -OVRLAP - CALL DCOPY (NCF, EVEC(JOFSET+1), 1, CMVL(IOFSET + 1), 1) - GO TO 123 - ELSE - GO TO 234 - ENDIF - END DO - ENDIF - + 234 CONTINUE + JOTHER = JOTHER - 1 + IF (JOTHER < 1) CYCLE + JOFSET = (JOTHER - 1)*NCF + NEVECPAT + OVRLAP = DDOT(NCF,EVEC(IOFSET+1),1,EVEC(JOFSET+1),1) + IF (OVRLAP /= 0.D0) THEN ! So SURE ??? + OMCDAJ = 1.D0 + CDAMPJ = -OVRLAP + CALL DCOPY (NCF, EVEC(JOFSET+1), 1, CMVL(IOFSET + 1), 1) + GO TO 123 + ELSE + GO TO 234 + ENDIF + END DO + ENDIF + ! Write out the eigenpair information: ASF symmetries, eigenvalues, ! and eigenvectors to GRASP92 mixing coefficients File - - IF (NEVBLK(JBLOCK) == 0) THEN - IATTMP = 999 - IASTMP = 999 - ELSE + + IF (NEVBLK(JBLOCK) == 0) THEN + IATTMP = 999 + IASTMP = 999 + ELSE !GGGG iattmp = IABS(JPGG(jblock)) IF(JPGG(jblock) .GE. 0) THEN @@ -276,35 +276,35 @@ SUBROUTINE MATRIXmpi(dvdfirst) ELSE iastmp = -1 END IF -!GG IATTMP = IATJPO(NCMINPAT + 1) -!GG IASTMP = IASPAR(NCMINPAT + 1) - ENDIF - - IF (MYID == 0) THEN - WRITE (25) JBLOCK, NCF, NEVBLK(JBLOCK), IATTMP, IASTMP - WRITE (25) (ICCMIN(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) - WRITE (25) EAV, (EVAL(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) +!GG IATTMP = IATJPO(NCMINPAT + 1) +!GG IASTMP = IASPAR(NCMINPAT + 1) + ENDIF + + IF (MYID == 0) THEN + WRITE (25) JBLOCK, NCF, NEVBLK(JBLOCK), IATTMP, IASTMP + WRITE (25) (ICCMIN(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) + WRITE (25) EAV, (EVAL(I + NCMINPAT),I=1,NEVBLK(JBLOCK)) WRITE (25) ((EVEC(I+(J-1)*NCF+NEVECPAT),I=1,NCF),J=1,NEVBLK(JBLOCK)& - ) - ENDIF - - CALL DALLOC (EMT, 'EMT', 'MATRIXmpi') - CALL DALLOC (IENDC, 'IENDC', 'MATRIXmpi') - CALL DALLOC (IROW, 'IROW', 'MATRIXmpi') - + ) + ENDIF + + CALL DALLOC (EMT, 'EMT', 'MATRIXmpi') + CALL DALLOC (IENDC, 'IENDC', 'MATRIXmpi') + CALL DALLOC (IROW, 'IROW', 'MATRIXmpi') + !---------------------- - END DO + END DO !---------------------- ! ! Deallocate the temporary storage ! - IF (.NOT.FIRST) THEN - CALL DALLOC (CMVL, 'CMVL', 'MATRIXmpi') - ELSE - FIRST = .FALSE. - ENDIF - - 302 FORMAT(' Average energy = ',1P,D18.10,' Hartrees') - - RETURN + IF (.NOT.FIRST) THEN + CALL DALLOC (CMVL, 'CMVL', 'MATRIXmpi') + ELSE + FIRST = .FALSE. + ENDIF + + 302 FORMAT(' Average energy = ',1P,D18.10,' Hartrees') + + RETURN END SUBROUTINE MATRIXmpi diff --git a/src/appl/rmcdhf90_mpi/matrixmpi_I.f90 b/src/appl/rmcdhf90_mpi/matrixmpi_I.f90 index c062df66c..e1ff9854f 100644 --- a/src/appl/rmcdhf90_mpi/matrixmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/matrixmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE matrixmpi_I + MODULE matrixmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:52:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE matrixmpi (dvdfirst) logical, INTENT(IN) :: dvdfirst - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/maxarr.f90 b/src/appl/rmcdhf90_mpi/maxarr.f90 index 98345329a..e34fa7d56 100644 --- a/src/appl/rmcdhf90_mpi/maxarr.f90 +++ b/src/appl/rmcdhf90_mpi/maxarr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MAXARR(J) + SUBROUTINE MAXARR(J) ! * ! This subroutine finds the least self-consistent orbital * ! * @@ -9,13 +9,13 @@ SUBROUTINE MAXARR(J) ! J initialized to zero ! XHH 1997.02.14 !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE fixd_C USE orb_C USE scf_C @@ -23,23 +23,23 @@ SUBROUTINE MAXARR(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(OUT) :: J + INTEGER , INTENT(OUT) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DLRGST + INTEGER :: I + REAL(DOUBLE) :: DLRGST !----------------------------------------------- ! ! - J = 0 - DLRGST = 0.D0 - DO I = 1, NW - IF (LFIX(I)) CYCLE - IF (SCNSTY(I) <= DLRGST) CYCLE - DLRGST = SCNSTY(I) - J = I - END DO + J = 0 + DLRGST = 0.D0 + DO I = 1, NW + IF (LFIX(I)) CYCLE + IF (SCNSTY(I) <= DLRGST) CYCLE + DLRGST = SCNSTY(I) + J = I + END DO ! - RETURN - END SUBROUTINE MAXARR + RETURN + END SUBROUTINE MAXARR diff --git a/src/appl/rmcdhf90_mpi/maxarr_I.f90 b/src/appl/rmcdhf90_mpi/maxarr_I.f90 index c9c7b1d85..7e8670e8c 100644 --- a/src/appl/rmcdhf90_mpi/maxarr_I.f90 +++ b/src/appl/rmcdhf90_mpi/maxarr_I.f90 @@ -1,10 +1,10 @@ - MODULE maxarr_I + MODULE maxarr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE maxarr (J) - INTEGER, INTENT(OUT) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE maxarr (J) + INTEGER, INTENT(OUT) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/newcompi.f90 b/src/appl/rmcdhf90_mpi/newcompi.f90 index 1774cf0be..8743badec 100644 --- a/src/appl/rmcdhf90_mpi/newcompi.f90 +++ b/src/appl/rmcdhf90_mpi/newcompi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NEWCOmpi(SUM) + SUBROUTINE NEWCOmpi(SUM) ! * ! This routine computes the level weights, the generalized occupa- * ! tion numbers, and average energy for EOL calculations; this * @@ -15,14 +15,14 @@ SUBROUTINE NEWCOmpi(SUM) ! It was deleted the arrays: JQSA(3*NNNWP*NCF), * ! JCUPA(NNNWP*NCF) * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C USE def_C USE eigv_C USE orb_C @@ -37,102 +37,102 @@ SUBROUTINE NEWCOmpi(SUM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dsubrs_I + USE dsubrs_I USE iq_I - USE csfwgt_I + USE csfwgt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(OUT) :: SUM + REAL(DOUBLE) , INTENT(OUT) :: SUM !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, NB, I, NOFF, JALL, JBLOCK - REAL(DOUBLE) :: WEITJ, EE - LOGICAL :: EOL + REAL(DOUBLE) :: WEITJ, EE + LOGICAL :: EOL !----------------------------------------------- ! Compute weighting factors ! - SUM = 0.D0 - DO J = 1, NCMIN - WEITJ = WEIGHT(J) - IF (WEITJ == (-2.D0)) THEN - WT(J) = 1.D0 - ELSE IF (WEITJ == (-1.D0)) THEN -!GG WT(J) = IATJPO(J) + SUM = 0.D0 + DO J = 1, NCMIN + WEITJ = WEIGHT(J) + IF (WEITJ == (-2.D0)) THEN + WT(J) = 1.D0 + ELSE IF (WEITJ == (-1.D0)) THEN +!GG WT(J) = IATJPO(J) jblock = idxblk(J) ! Block number of this state WT(J) = ABS(JPGG(jblock)) - ELSE - WT(J) = WEIGHT(J) - ENDIF - SUM = SUM + WT(J) - END DO - - WT(:NCMIN) = WT(:NCMIN)/SUM + ELSE + WT(J) = WEIGHT(J) + ENDIF + SUM = SUM + WT(J) + END DO + + WT(:NCMIN) = WT(:NCMIN)/SUM ! ! Compute generalised occupation numbers ! <----- Distributed -----> ! - EOL = .TRUE. - - DO J = 1, NW - SUM = 0.D0 - DO NB = 1, NBLOCK - DO I = MYID + 1, NCFBLK(NB), NPROCS - SUM = SUM + DSUBRS(EOL,I,I,NB)*IQ(J,I + NCFPAST(NB)) - END DO - END DO -! UCF(J) = SUM + EOL = .TRUE. + + DO J = 1, NW + SUM = 0.D0 + DO NB = 1, NBLOCK + DO I = MYID + 1, NCFBLK(NB), NPROCS + SUM = SUM + DSUBRS(EOL,I,I,NB)*IQ(J,I + NCFPAST(NB)) + END DO + END DO +! UCF(J) = SUM CALL MPI_Allreduce (SUM, UCF(J), 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) - END DO + END DO ! ! Write out level energies and weights ! - IF(MYID == 0) WRITE (*, 300) - SUM = 0.D0 - NOFF = 0 - DO JALL = 1, NCMIN - NB = IDXBLK(JALL) ! Block number of this state - EE = EAVBLK(NB) + EVAL(JALL) + IF(MYID == 0) WRITE (*, 300) + SUM = 0.D0 + NOFF = 0 + DO JALL = 1, NCMIN + NB = IDXBLK(JALL) ! Block number of this state + EE = EAVBLK(NB) + EVAL(JALL) if (myid .eq. 0) then - WRITE (*, 301) ICCMIN(JALL), EE, WT(JALL) - IF (LDBPG(5)) THEN - WRITE (99, *) JALL, NB, NCFBLK(NB), NEVECPAST(NB) - WRITE (99, 302) - WRITE (99, 303) (EVEC(I + NOFF),I=1,NCFBLK(NB)) - NOFF = NOFF + NCFBLK(NB) - ENDIF - ENDIF - SUM = SUM + WT(JALL)*EE - END DO + WRITE (*, 301) ICCMIN(JALL), EE, WT(JALL) + IF (LDBPG(5)) THEN + WRITE (99, *) JALL, NB, NCFBLK(NB), NEVECPAST(NB) + WRITE (99, 302) + WRITE (99, 303) (EVEC(I + NOFF),I=1,NCFBLK(NB)) + NOFF = NOFF + NCFBLK(NB) + ENDIF + ENDIF + SUM = SUM + WT(JALL)*EE + END DO !~~~~~~~~~ IF (myid .EQ. 0) THEN !~~~~~~~~~ - CALL CSFWGT (.TRUE.) + CALL CSFWGT (.TRUE.) ! ! Write out average energy ! - IF (NCMIN > 1) WRITE (*, 304) SUM + IF (NCMIN > 1) WRITE (*, 304) SUM WRITE (0,'(A25,1PD18.10)') 'Weighted average energy: ', SUM ! ! Write out generalized occupation numbers ! - WRITE (*, 305) - WRITE (*, 303) (UCF(I),I=1,NW) + WRITE (*, 305) + WRITE (*, 303) (UCF(I),I=1,NW) !~~~~~~~~~ ENDIF !~~~~~~~~~ - - 300 FORMAT(/,'Optimise on the following level(s):'/) - 301 FORMAT('Level ',1I2,4X,'Energy = ',1P,1D19.12,4X,'Weight = ',1D12.5) - 302 FORMAT(/,'Configuration mixing coefficients:') - 303 FORMAT(1X,1P,6D12.4) - 304 FORMAT(/,'Weighted average energy of these levels = ',1P,D18.10) - 305 FORMAT(/,'Generalised occupation numbers:'/) - - RETURN + + 300 FORMAT(/,'Optimise on the following level(s):'/) + 301 FORMAT('Level ',1I2,4X,'Energy = ',1P,1D19.12,4X,'Weight = ',1D12.5) + 302 FORMAT(/,'Configuration mixing coefficients:') + 303 FORMAT(1X,1P,6D12.4) + 304 FORMAT(/,'Weighted average energy of these levels = ',1P,D18.10) + 305 FORMAT(/,'Generalised occupation numbers:'/) + + RETURN END SUBROUTINE NEWCOmpi diff --git a/src/appl/rmcdhf90_mpi/newcompi_I.f90 b/src/appl/rmcdhf90_mpi/newcompi_I.f90 index 3d2d8c12e..84c53a121 100644 --- a/src/appl/rmcdhf90_mpi/newcompi_I.f90 +++ b/src/appl/rmcdhf90_mpi/newcompi_I.f90 @@ -1,11 +1,11 @@ - MODULE newcompi_I + MODULE newcompi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:53:04 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE newcompi (SUM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(OUT) :: SUM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE newcompi (SUM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(OUT) :: SUM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/newe.f90 b/src/appl/rmcdhf90_mpi/newe.f90 index 8026ba04b..12def6457 100644 --- a/src/appl/rmcdhf90_mpi/newe.f90 +++ b/src/appl/rmcdhf90_mpi/newe.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) ! * ! This subroutine implements Part 2 of Algorithm 7.1 in C Froese * ! Fischer, Comput Phys Rep, 3 (1986) 273-326. (The present code * @@ -12,116 +12,116 @@ SUBROUTINE NEWE(J, SGN, NPRIME, MX, DELEPS, FAIL, INV) ! Written by Farid A Parpia, at Oxford Last Update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE int_C USE orb_C USE scf_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE outbnd_I + USE outbnd_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: NPRIME - INTEGER, INTENT(IN) :: MX - INTEGER, INTENT(OUT) :: INV - REAL(DOUBLE), INTENT(IN) :: SGN - REAL(DOUBLE), INTENT(INOUT) :: DELEPS - LOGICAL, INTENT(OUT) :: FAIL + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: NPRIME + INTEGER, INTENT(IN) :: MX + INTEGER, INTENT(OUT) :: INV + REAL(DOUBLE), INTENT(IN) :: SGN + REAL(DOUBLE), INTENT(INOUT) :: DELEPS + LOGICAL, INTENT(OUT) :: FAIL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P02 = 2.0D-02 - REAL(DOUBLE), PARAMETER :: P05 = 5.0D-02 - REAL(DOUBLE), PARAMETER :: P001 = 1.0D-03 - REAL(DOUBLE), PARAMETER :: P00001 = 1.0D-05 - REAL(DOUBLE), PARAMETER :: D2P5 = 2.5D00 + REAL(DOUBLE), PARAMETER :: P02 = 2.0D-02 + REAL(DOUBLE), PARAMETER :: P05 = 5.0D-02 + REAL(DOUBLE), PARAMETER :: P001 = 1.0D-03 + REAL(DOUBLE), PARAMETER :: P00001 = 1.0D-05 + REAL(DOUBLE), PARAMETER :: D2P5 = 2.5D00 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: EPS, ABDELE, DELEBE, DN, DNPRME, DNPN25, ETRY, DELTA + INTEGER :: I + REAL(DOUBLE) :: EPS, ABDELE, DELEBE, DN, DNPRME, DNPN25, ETRY, DELTA !----------------------------------------------- ! ! ! Determine if the iterative process has succeeded ! - IF (SGN>0.0D00 .AND. MX==0) THEN - FAIL = .FALSE. - ELSE - FAIL = .TRUE. - ENDIF + IF (SGN>0.0D00 .AND. MX==0) THEN + FAIL = .FALSE. + ELSE + FAIL = .TRUE. + ENDIF ! ! Inversion counter ! - INV = 0 + INV = 0 ! ! If unsuccessful, obtain a new estimate of the eigenvalue ! - IF (FAIL) THEN + IF (FAIL) THEN ! ! Define quantities used later ! - EPS = E(J) - ABDELE = ABS(DELEPS) - DELEBE = ABS(DELEPS/EPS) - DN = DBLE(NP(J)) - DNPRME = DBLE(NPRIME) - DNPN25 = (DNPRME/DN)**D2P5 + EPS = E(J) + ABDELE = ABS(DELEPS) + DELEBE = ABS(DELEPS/EPS) + DN = DBLE(NP(J)) + DNPRME = DBLE(NPRIME) + DNPN25 = (DNPRME/DN)**D2P5 ! IF (ABS(MX)==1 .AND. DELEBE>P02 .OR. MX==0 .AND. DELEBE>=P00001 .AND. & - ABDELE>=P001) THEN - 1 CONTINUE - ETRY = EPS + DELEPS - IF (OUTBND(ETRY) .AND. MX/=0) ETRY = EPS*DNPN25 - IF (OUTBND(ETRY)) ETRY = EPS - DELEPS - IF (OUTBND(ETRY)) THEN - DELEPS = 0.5D00*DELEPS - GO TO 1 - ENDIF - ELSE IF (MX == 0) THEN - ETRY = EPS - INV = 1 - P0 = -P0 - P(:MTP0) = -P(:MTP0) - Q(:MTP0) = -Q(:MTP0) - FAIL = .FALSE. - ELSE IF (SGN < 0.0D00) THEN - ETRY = EPS*DNPN25 - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPS) - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMIN + EPS) - ELSE IF (MX < 0) THEN - DELTA = 1.0D00 - EPS/EPSMAX - EPSMAX = EPS - IF (DELTA < P05) THEN - EMAX = EMAX*DNPN25 - ELSE - EMAX = EPS*DNPN25 - ENDIF - ETRY = EMAX - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) - ELSE IF (MX > 0) THEN - DELTA = 1.0D00 - EPSMIN/EPS - EPSMIN = EPS - IF (DELTA < P05) THEN - EMIN = EMIN*DNPN25 - ELSE - EMIN = EPS*DNPN25 - ENDIF - ETRY = EMIN - IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) - ENDIF - E(J) = ETRY - ENDIF + ABDELE>=P001) THEN + 1 CONTINUE + ETRY = EPS + DELEPS + IF (OUTBND(ETRY) .AND. MX/=0) ETRY = EPS*DNPN25 + IF (OUTBND(ETRY)) ETRY = EPS - DELEPS + IF (OUTBND(ETRY)) THEN + DELEPS = 0.5D00*DELEPS + GO TO 1 + ENDIF + ELSE IF (MX == 0) THEN + ETRY = EPS + INV = 1 + P0 = -P0 + P(:MTP0) = -P(:MTP0) + Q(:MTP0) = -Q(:MTP0) + FAIL = .FALSE. + ELSE IF (SGN < 0.0D00) THEN + ETRY = EPS*DNPN25 + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPS) + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMIN + EPS) + ELSE IF (MX < 0) THEN + DELTA = 1.0D00 - EPS/EPSMAX + EPSMAX = EPS + IF (DELTA < P05) THEN + EMAX = EMAX*DNPN25 + ELSE + EMAX = EPS*DNPN25 + ENDIF + ETRY = EMAX + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) + ELSE IF (MX > 0) THEN + DELTA = 1.0D00 - EPSMIN/EPS + EPSMIN = EPS + IF (DELTA < P05) THEN + EMIN = EMIN*DNPN25 + ELSE + EMIN = EPS*DNPN25 + ENDIF + ETRY = EMIN + IF (OUTBND(ETRY)) ETRY = 0.5D00*(EPSMAX + EPSMIN) + ENDIF + E(J) = ETRY + ENDIF ! - RETURN - END SUBROUTINE NEWE + RETURN + END SUBROUTINE NEWE diff --git a/src/appl/rmcdhf90_mpi/newe_I.f90 b/src/appl/rmcdhf90_mpi/newe_I.f90 index 74086cfa0..ff75662e1 100644 --- a/src/appl/rmcdhf90_mpi/newe_I.f90 +++ b/src/appl/rmcdhf90_mpi/newe_I.f90 @@ -1,17 +1,17 @@ - MODULE newe_I + MODULE newe_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE newe (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(IN) :: SGN - INTEGER, INTENT(IN) :: NPRIME - INTEGER, INTENT(IN) :: MX - REAL(DOUBLE), INTENT(INOUT) :: DELEPS - LOGICAL, INTENT(OUT) :: FAIL - INTEGER, INTENT(OUT) :: INV - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE newe (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(IN) :: SGN + INTEGER, INTENT(IN) :: NPRIME + INTEGER, INTENT(IN) :: MX + REAL(DOUBLE), INTENT(INOUT) :: DELEPS + LOGICAL, INTENT(OUT) :: FAIL + INTEGER, INTENT(OUT) :: INV + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/orbout.f90 b/src/appl/rmcdhf90_mpi/orbout.f90 index c2fb9656e..51bb929e0 100644 --- a/src/appl/rmcdhf90_mpi/orbout.f90 +++ b/src/appl/rmcdhf90_mpi/orbout.f90 @@ -1,13 +1,13 @@ !*********************************************************************** - SUBROUTINE ORBOUT(RWFFILE2) + SUBROUTINE ORBOUT(RWFFILE2) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE orb_C USE wave_C @@ -15,23 +15,23 @@ SUBROUTINE ORBOUT(RWFFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: RWFFILE2*(*) + CHARACTER , INTENT(IN) :: RWFFILE2*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, MFJ, I + INTEGER :: J, MFJ, I !----------------------------------------------- ! OPEN(23, FILE=RWFFILE2, STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - WRITE (23) 'G92RWF' - DO J = 1, NW - MFJ = MF(J) - WRITE (23) NP(J), NAK(J), E(J), MFJ - WRITE (23) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) - WRITE (23) (R(I),I=1,MFJ) ! This is a waste of resources - END DO - CLOSE(23) - - RETURN - END SUBROUTINE ORBOUT + 'asis') + WRITE (23) 'G92RWF' + DO J = 1, NW + MFJ = MF(J) + WRITE (23) NP(J), NAK(J), E(J), MFJ + WRITE (23) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) + WRITE (23) (R(I),I=1,MFJ) ! This is a waste of resources + END DO + CLOSE(23) + + RETURN + END SUBROUTINE ORBOUT diff --git a/src/appl/rmcdhf90_mpi/orbout_I.f90 b/src/appl/rmcdhf90_mpi/orbout_I.f90 index 5e909547f..681946f89 100644 --- a/src/appl/rmcdhf90_mpi/orbout_I.f90 +++ b/src/appl/rmcdhf90_mpi/orbout_I.f90 @@ -1,10 +1,10 @@ - MODULE orbout_I + MODULE orbout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orbout (RWFFILE2) - CHARACTER (LEN = *), INTENT(IN) :: RWFFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE orbout (RWFFILE2) + CHARACTER (LEN = *), INTENT(IN) :: RWFFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/orthor.f90 b/src/appl/rmcdhf90_mpi/orthor.f90 index 16599aeb3..c9659e1fd 100644 --- a/src/appl/rmcdhf90_mpi/orthor.f90 +++ b/src/appl/rmcdhf90_mpi/orthor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ORTHOR(J, INV) + SUBROUTINE ORTHOR(J, INV) ! ! * ! This routine Schmidt orthogonalizes orbital J to all orbitals * @@ -18,18 +18,18 @@ SUBROUTINE ORTHOR(J, INV) ! Anyway this routine was not used anywhere. !XHH 1997.02.21 !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEF_C + USE DEF_C USE GRID_C - USE OVL_C - USE ORB_C + USE OVL_C + USE ORB_C USE ORBA_C USE INVT_C USE SCF_C @@ -39,37 +39,37 @@ SUBROUTINE ORTHOR(J, INV) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I -! USE count_I + USE rint_I +! USE count_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER , INTENT(INOUT) :: INV + INTEGER :: J + INTEGER , INTENT(INOUT) :: INV !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KRAW, K, MTP, I, NNCFF, JGG - REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR, SGN - LOGICAL :: CHECK, CHANGED + REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR, SGN + LOGICAL :: CHECK, CHANGED !----------------------------------------------- ! !XHH Added common /orba/ and /iounit/ - + ! !ww EPS = ACCY*0.1D 00 - EPS = ACCY*0.01D00 + EPS = ACCY*0.01D00 ! - CHECK = .NOT.NOINVT(J) + CHECK = .NOT.NOINVT(J) ! !XHH ! Bug fixed. Here J is actually IORDER(J_raw), thus K should be ! treated the same way. - CHANGED = .FALSE. + CHANGED = .FALSE. ! DO 4 K = 1,NW - DO KRAW = 1, NW - K = IORDER(KRAW) + DO KRAW = 1, NW + K = IORDER(KRAW) ! write(istde,*) '***',kraw,k,np(k),nh(k),scnsty(k),'***' ! !XHH orbitals with higher self-consistency are considered @@ -80,63 +80,63 @@ SUBROUTINE ORTHOR(J, INV) ! IF ( (K .NE. J) .AND. ! : (NAK(K) .EQ. NAK(J)) ) THEN !XHH orbitals before the current and unchanged ones are considered - IF (.NOT.(NAK(K)==NAK(J) .AND. (K= SCNSTY(KI)/E(KI)**2) CYCLE - + + DO I = KFIXED + 1, KFIXED + KNON + KI = KINDX(I) + DO J = I + 1, KFIXED + KNON + KJ = KINDX(J) + IF (SCNSTY(KJ)/E(KJ)**2 >= SCNSTY(KI)/E(KI)**2) CYCLE + ! No need to do shifting, exchanging is fine - KINDX(J) = KI - KI = KJ - END DO - KINDX(I) = KI - END DO - + KINDX(J) = KI + KI = KJ + END DO + KINDX(I) = KI + END DO + ! correlation orbitals, using criteria scnsty - - DO I = KFIXED + KNON + 1, KTOTAL - KI = KINDX(I) - DO J = I + 1, KTOTAL - KJ = KINDX(J) - IF (SCNSTY(KJ) >= SCNSTY(KI)) CYCLE - + + DO I = KFIXED + KNON + 1, KTOTAL + KI = KINDX(I) + DO J = I + 1, KTOTAL + KJ = KINDX(J) + IF (SCNSTY(KJ) >= SCNSTY(KI)) CYCLE + ! No need to do shifting, exchanging is fine - KINDX(J) = KI - KI = KJ - END DO - KINDX(I) = KI - END DO - - ENDIF - + KINDX(J) = KI + KI = KJ + END DO + KINDX(I) = KI + END DO + + ENDIF + ! Finished sorting. ! Schmidt orthogonalize all orbitals of the same kappa ! The fixed orbitals are not changed - - DO LRAW = KFIXED + 1, KTOTAL - L = KINDX(LRAW) - - NAKL = NAK(L) - - MTP0 = MF(L) - - DO KRAW = 1, LRAW - 1 - K = KINDX(KRAW) - OVRLAP = RINT(L,K,0) - + + DO LRAW = KFIXED + 1, KTOTAL + L = KINDX(LRAW) + + NAKL = NAK(L) + + MTP0 = MF(L) + + DO KRAW = 1, LRAW - 1 + K = KINDX(KRAW) + OVRLAP = RINT(L,K,0) + ! Schmidt orthogonalise - - PZ(L) = PZ(L) - OVRLAP*PZ(K) - MTP = MAX(MF(L),MF(K)) - MTP0 = MAX(MTP0,MF(K)) - - PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) - QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) - END DO - + + PZ(L) = PZ(L) - OVRLAP*PZ(K) + MTP = MAX(MF(L),MF(K)) + MTP0 = MAX(MTP0,MF(K)) + + PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) + QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) + END DO + ! Normalise - - MTP = MTP0 - - MF(L) = MTP - DNORM = RINT(L,L,0) - FACTOR = 1.D0/SQRT(DNORM) - - IF (PZ(L) < 0.D0) FACTOR = -FACTOR - - PZ(L) = FACTOR*PZ(L) - PF(2:MTP,L) = FACTOR*PF(2:MTP,L) - QF(2:MTP,L) = FACTOR*QF(2:MTP,L) - + + MTP = MTP0 + + MF(L) = MTP + DNORM = RINT(L,L,0) + FACTOR = 1.D0/SQRT(DNORM) + + IF (PZ(L) < 0.D0) FACTOR = -FACTOR + + PZ(L) = FACTOR*PZ(L) + PF(2:MTP,L) = FACTOR*PF(2:MTP,L) + QF(2:MTP,L) = FACTOR*QF(2:MTP,L) + ! Find new MF(L) - - MTP = MTP + 1 - 20 CONTINUE - MTP = MTP - 1 - IF (ABS(PF(MTP,L)) < EPS) THEN - PF(MTP,L) = 0.D0 - QF(MTP,L) = 0.D0 - GO TO 20 - ELSE - MF(L) = MTP - ENDIF - - END DO - - RETURN - END SUBROUTINE ORTHY + + MTP = MTP + 1 + 20 CONTINUE + MTP = MTP - 1 + IF (ABS(PF(MTP,L)) < EPS) THEN + PF(MTP,L) = 0.D0 + QF(MTP,L) = 0.D0 + GO TO 20 + ELSE + MF(L) = MTP + ENDIF + + END DO + + RETURN + END SUBROUTINE ORTHY diff --git a/src/appl/rmcdhf90_mpi/orthy_I.f90 b/src/appl/rmcdhf90_mpi/orthy_I.f90 index e7dab74ad..20b005ea5 100644 --- a/src/appl/rmcdhf90_mpi/orthy_I.f90 +++ b/src/appl/rmcdhf90_mpi/orthy_I.f90 @@ -1,12 +1,12 @@ - MODULE orthy_I + MODULE orthy_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:57:18 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:57:18 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orthy (NW, JP, LSORT) - INTEGER, INTENT(IN) :: NW - INTEGER, INTENT(IN) :: JP - LOGICAL, INTENT(IN) :: LSORT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE orthy (NW, JP, LSORT) + INTEGER, INTENT(IN) :: NW + INTEGER, INTENT(IN) :: JP + LOGICAL, INTENT(IN) :: LSORT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/out.f90 b/src/appl/rmcdhf90_mpi/out.f90 index 6577bf7eb..afe8e7a90 100644 --- a/src/appl/rmcdhf90_mpi/out.f90 +++ b/src/appl/rmcdhf90_mpi/out.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE OUT(J, JP, P, Q) + SUBROUTINE OUT(J, JP, P, Q) ! * ! This subroutine carries out the step-by-step outward integration * ! of a pair of inhomogeneous Dirac radial equations. * @@ -17,13 +17,13 @@ SUBROUTINE OUT(J, JP, P, Q) ! Written by Farid A Parpia, at Oxford Last updated: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE grid_C, ONLY: h, rpor USE int_C, ONLY: TF ,TG ,XU, XV @@ -32,58 +32,58 @@ SUBROUTINE OUT(J, JP, P, Q) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J - INTEGER , INTENT(IN) :: JP - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: JP + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I REAL(DOUBLE) :: DKHB2, DKHB2F, CPI, CMI, PI, QI, TFI, TGI, CPIM1, CMIM1, & - PIM1, QIM1, TFIM1, TGIM1, UCIM1, UDIM1, UEI + PIM1, QIM1, TFIM1, TGIM1, UCIM1, UDIM1, UEI !----------------------------------------------- ! ! One global initialization ! - DKHB2 = 0.5D00*H*DBLE(NAK(J)) + DKHB2 = 0.5D00*H*DBLE(NAK(J)) ! ! Tabulate P(r) and Q(r) by step-by-step integration ! ! Initializations: set quantities for I = 3 ! - I = 3 - DKHB2F = DKHB2*RPOR(I) - CPI = 1.0D00 + DKHB2F - CMI = 1.0D00 - DKHB2F - PI = P(I) - QI = Q(I) - TFI = TF(I) - TGI = TG(I) + I = 3 + DKHB2F = DKHB2*RPOR(I) + CPI = 1.0D00 + DKHB2F + CMI = 1.0D00 - DKHB2F + PI = P(I) + QI = Q(I) + TFI = TF(I) + TGI = TG(I) ! ! March out to from I = 4 to I = JP ! !XHH Use doo-loop - DO I = 4, JP - CPIM1 = CPI - CMIM1 = CMI - DKHB2F = DKHB2*RPOR(I) - CPI = 1.0D00 + DKHB2F - CMI = 1.0D00 - DKHB2F - PIM1 = PI - QIM1 = QI - TFIM1 = TFI - TGIM1 = TGI - TFI = TF(I) - TGI = TG(I) - UCIM1 = CMIM1*PIM1 - TFIM1*QIM1 + XU(I-1) - UDIM1 = CPIM1*QIM1 - TGIM1*PIM1 + XV(I-1) - UEI = CPI*CMI - TFI*TGI - PI = (CMI*UCIM1 - TFI*UDIM1)/UEI - QI = (CPI*UDIM1 - TGI*UCIM1)/UEI - P(I) = PI - Q(I) = QI - END DO + DO I = 4, JP + CPIM1 = CPI + CMIM1 = CMI + DKHB2F = DKHB2*RPOR(I) + CPI = 1.0D00 + DKHB2F + CMI = 1.0D00 - DKHB2F + PIM1 = PI + QIM1 = QI + TFIM1 = TFI + TGIM1 = TGI + TFI = TF(I) + TGI = TG(I) + UCIM1 = CMIM1*PIM1 - TFIM1*QIM1 + XU(I-1) + UDIM1 = CPIM1*QIM1 - TGIM1*PIM1 + XV(I-1) + UEI = CPI*CMI - TFI*TGI + PI = (CMI*UCIM1 - TFI*UDIM1)/UEI + QI = (CPI*UDIM1 - TGI*UCIM1)/UEI + P(I) = PI + Q(I) = QI + END DO ! - RETURN - END SUBROUTINE OUT + RETURN + END SUBROUTINE OUT diff --git a/src/appl/rmcdhf90_mpi/out_I.f90 b/src/appl/rmcdhf90_mpi/out_I.f90 index 9a80a076e..a3fc2259f 100644 --- a/src/appl/rmcdhf90_mpi/out_I.f90 +++ b/src/appl/rmcdhf90_mpi/out_I.f90 @@ -1,15 +1,15 @@ - MODULE out_I + MODULE out_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE out (J, JP, P, Q) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE out (J, JP, P, Q) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: JP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: JP + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/outbnd.f90 b/src/appl/rmcdhf90_mpi/outbnd.f90 index 4a185ed75..0d775d858 100644 --- a/src/appl/rmcdhf90_mpi/outbnd.f90 +++ b/src/appl/rmcdhf90_mpi/outbnd.f90 @@ -1,7 +1,7 @@ - + !*********************************************************************** ! * - LOGICAL FUNCTION OUTBND (ETRY) + LOGICAL FUNCTION OUTBND (ETRY) ! * ! This subprogram determines whether the trial eigenvalue etry is * ! within the bounds (EPSMIN,EPSMAX) * @@ -9,29 +9,29 @@ LOGICAL FUNCTION OUTBND (ETRY) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE SCF_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: ETRY + REAL(DOUBLE) , INTENT(IN) :: ETRY !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! - IF (ETRY>EPSMIN .AND. ETRYEPSMIN .AND. ETRY 75) THEN - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - ENDIF - IF (IEND > 0) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - ENDIF - IBEG = IEND + 1 - CALL CONVRT (NP(LOC), CNUM, LENTH) - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IF (NAK(LOC) < 0) THEN - LENTH = 1 - ELSE - LENTH = 2 - ENDIF - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = NH(LOC)(1:LENTH) + IF (IEND > 75) THEN + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + ENDIF + IF (IEND > 0) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + ENDIF + IBEG = IEND + 1 + CALL CONVRT (NP(LOC), CNUM, LENTH) + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IF (NAK(LOC) < 0) THEN + LENTH = 1 + ELSE + LENTH = 2 + ENDIF + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = NH(LOC)(1:LENTH) ! ENDIF - END DO - IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) + END DO + IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) ! - RETURN - END SUBROUTINE PRTRSL + RETURN + END SUBROUTINE PRTRSL diff --git a/src/appl/rmcdhf90_mpi/prtrsl_I.f90 b/src/appl/rmcdhf90_mpi/prtrsl_I.f90 index 8af1a6406..ae75c4208 100644 --- a/src/appl/rmcdhf90_mpi/prtrsl_I.f90 +++ b/src/appl/rmcdhf90_mpi/prtrsl_I.f90 @@ -1,9 +1,9 @@ - MODULE prtrsl_I + MODULE prtrsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prtrsl - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE prtrsl + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/prwf.f90 b/src/appl/rmcdhf90_mpi/prwf.f90 index 61f971dd3..8684ae5aa 100644 --- a/src/appl/rmcdhf90_mpi/prwf.f90 +++ b/src/appl/rmcdhf90_mpi/prwf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRWF(J) + SUBROUTINE PRWF(J) ! * ! Makes a (debug) printout of wave functions. There are two modes: * ! * @@ -14,11 +14,11 @@ SUBROUTINE PRWF(J) ! Written by Farid A Parpia, at Oxford Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP @@ -30,79 +30,79 @@ SUBROUTINE PRWF(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- -! USE draw_I +! USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NB2, NROWS, II, II1, II2, K, MFK, JGG - REAL(DOUBLE) :: CBZ + REAL(DOUBLE) :: CBZ !----------------------------------------------- ! ! - CBZ = C/Z + CBZ = C/Z ! - IF (J > 0) THEN + IF (J > 0) THEN ! ! Mode (1) ! - WRITE (99, 300) NP(J), NH(J) - NB2 = MTP0/2 - IF (2*NB2 == MTP0) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= MTP0) THEN - WRITE (99, 301) R(II1), P(II1), Q(II1), R(II2), P(II2), Q(II2) - ELSE IF (II1 <= MTP0) THEN - WRITE (99, 301) R(II1), P(II1), Q(II1) - ENDIF - END DO - CALL DRAW (P, 1.0D00, Q, CBZ, MTP0) + WRITE (99, 300) NP(J), NH(J) + NB2 = MTP0/2 + IF (2*NB2 == MTP0) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= MTP0) THEN + WRITE (99, 301) R(II1), P(II1), Q(II1), R(II2), P(II2), Q(II2) + ELSE IF (II1 <= MTP0) THEN + WRITE (99, 301) R(II1), P(II1), Q(II1) + ENDIF + END DO + CALL DRAW (P, 1.0D00, Q, CBZ, MTP0) ! - ELSE + ELSE ! ! Mode (2) ! - DO K = 1, NW - WRITE (99, 300) NP(K), NH(K) - MFK = MF(K) - NB2 = MFK/2 - IF (2*NB2 == MFK) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= MFK) THEN + DO K = 1, NW + WRITE (99, 300) NP(K), NH(K) + MFK = MF(K) + NB2 = MFK/2 + IF (2*NB2 == MFK) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= MFK) THEN WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K), R(II2), PF(II2,& - K), QF(II2,K) - ELSE IF (II1 <= MFK) THEN - WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K) - ENDIF - END DO - CALL DRAW (PF(:NNNP,K), 1.0D00, QF(:NNNP,K), CBZ, MF(K)) + K), QF(II2,K) + ELSE IF (II1 <= MFK) THEN + WRITE (99, 301) R(II1), PF(II1,K), QF(II1,K) + ENDIF + END DO + CALL DRAW (PF(:NNNP,K), 1.0D00, QF(:NNNP,K), CBZ, MF(K)) ! - END DO + END DO ! - ENDIF + ENDIF ! - RETURN + RETURN ! 300 FORMAT('1',1I2,1A2,' orbital:'/,2(& ' --------- r --------- ------- P (r) -------',& - ' ------- Q (r) -------')) - 301 FORMAT(1P,6(1X,1D21.14)) - RETURN + ' ------- Q (r) -------')) + 301 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE PRWF + END SUBROUTINE PRWF diff --git a/src/appl/rmcdhf90_mpi/prwf_I.f90 b/src/appl/rmcdhf90_mpi/prwf_I.f90 index 61a656560..2a9801a08 100644 --- a/src/appl/rmcdhf90_mpi/prwf_I.f90 +++ b/src/appl/rmcdhf90_mpi/prwf_I.f90 @@ -1,10 +1,10 @@ - MODULE prwf_I + MODULE prwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prwf (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE prwf (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/rscfmpivu.f90 b/src/appl/rmcdhf90_mpi/rscfmpivu.f90 index 22ee745ec..1ae29c179 100644 --- a/src/appl/rmcdhf90_mpi/rscfmpivu.f90 +++ b/src/appl/rmcdhf90_mpi/rscfmpivu.f90 @@ -23,7 +23,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM RSCFmpiVU + PROGRAM RSCFmpiVU ! * ! Entry routine for RSCFVU. Controls the entire computation. * ! * @@ -39,33 +39,33 @@ PROGRAM RSCFmpiVU ! JCUPA(NNNWP*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:57:54 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:57:54 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE default_C USE core_C - USE iounit_C + USE iounit_C USE mpi_C !GG po to isimti USE TATB_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbgmpi_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setmcp_I - USE setcslmpi_I - USE getscdmpi_I - USE strsum_I - USE setmix_I - USE factt_I - USE scfmpi_I + USE getyn_I + USE setdbgmpi_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setmcp_I + USE setcslmpi_I + USE getscdmpi_I + USE strsum_I + USE setmix_I + USE factt_I + USE scfmpi_I IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s @@ -75,7 +75,7 @@ PROGRAM RSCFmpiVU ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NCORE1, NCOUNT1, lenperm, lentmp - LOGICAL :: EOL, YES + LOGICAL :: EOL, YES CHARACTER, DIMENSION(NBLK0) :: IDBLK*8 ! CHARACTER (LEN = *) :: host CHARACTER (LEN = 3) :: idstring @@ -95,25 +95,25 @@ PROGRAM RSCFmpiVU WRITE (idstring, '(I3.3)') myid lenperm = LEN_TRIM (permdir) lentmp = LEN_TRIM (tmpdir) - + !======================================================================= ! Get NDEF !======================================================================= - - IF (MYID == 0) THEN + + IF (MYID == 0) THEN WRITE (istde,*) - WRITE (ISTDE, '(A)') 'Default settings? (y/n) ' - YES = GETYN() - IF (YES) THEN - NDEF = 0 + WRITE (ISTDE, '(A)') 'Default settings? (y/n) ' + YES = GETYN() + IF (YES) THEN + NDEF = 0 !cjb fort.734 !cjb WRITE(734,'(A)') 'y ! Default settings' - ELSE - NDEF = 1 - ENDIF - ENDIF + ELSE + NDEF = 1 + ENDIF + ENDIF CALL MPI_Bcast (NDEF,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - + !======================================================================= ! ! Checks and settings... Mostly done in backyard. @@ -129,22 +129,22 @@ PROGRAM RSCFmpiVU ! SETMIX - mixing coefficients file setup ! FACTT - table of logarithms of factorials setup !======================================================================= - CALL SETDBGmpi (permdir(1:lenperm) // '/rscf92.dbg') - CALL SETMC - CALL SETCON - + CALL SETDBGmpi (permdir(1:lenperm) // '/rscf92.dbg') + CALL SETMC + CALL SETCON + IF (myid .EQ. 0) CALL SETSUM (permdir(1:lenperm) // '/rmcdhf.sum') - - CALL SETMCP (NCORE, NBLK0, IDBLK, 'mcp' // idstring) + + CALL SETMCP (NCORE, NBLK0, IDBLK, 'mcp' // idstring) if(myid == 0) file_rcsl = permdir(1:lenperm)//'/rcsf.inp' CALL SETCSLmpi (file_rcsl, ncore1, idblk) - IF (NCORE /= NCORE1) STOP 'rscfmpivu: ncore' - + IF (NCORE /= NCORE1) STOP 'rscfmpivu: ncore' + !======================================================================= ! Gather all remaining information and perform some setup. This ! part (routine) asks for user-inputs. !======================================================================= - + if(myid == 0) file1 = permdir(1:lenperm) // '/isodata' if(myid == 0) file2 = permdir(1:lenperm) // '/rwfn.inp' CALL GETSCDmpi (EOL, idblk, file1, file2 ) @@ -156,23 +156,23 @@ PROGRAM RSCFmpiVU CALL STRSUM IF (EOL) CALL SETMIX (file1) ENDIF - - CALL FACTT - + + CALL FACTT + !======================================================================= ! Proceed with the SCF calculation close all files except ! the .sum file !======================================================================= - + file1 = ' ' if(myid == 0) file1 = permdir(1:lenperm) // '/rwfn.out' CALL scfmpi (EOL, file1) - + !======================================================================= ! Execution finished; Statistics output !======================================================================= - + CALL stopmpi2 (myid, nprocs, host, lenhost, ncount1, 'RMCDHF_MPI') - END PROGRAM RSCFmpiVU + END PROGRAM RSCFmpiVU diff --git a/src/appl/rmcdhf90_mpi/scfmpi.f90 b/src/appl/rmcdhf90_mpi/scfmpi.f90 index 490eb97d9..8323178c7 100644 --- a/src/appl/rmcdhf90_mpi/scfmpi.f90 +++ b/src/appl/rmcdhf90_mpi/scfmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SCFmpi(EOL, RWFFILE2) + SUBROUTINE SCFmpi(EOL, RWFFILE2) ! * ! This subroutine performs the SCF iterations. The procedure is * ! essentially algorithm 5.1 of C Froese Fischer, Comput Phys Rep 3 * @@ -18,13 +18,13 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) ! JCUPA(NNNWP*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE blkidx_C USE default_C @@ -35,11 +35,11 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) USE hblock_C USE iounit_C USE lagr_C - USE MCPA_C + USE MCPA_C USE mpi_C USE pos_c USE peav_C - USE ORB_C + USE ORB_C USE orba_C USE SCF_C USE SYMA_C @@ -48,15 +48,15 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE matrixmpi_I - USE newcompi_I - USE setlagmpi_I - USE improvmpi_I - USE maxarr_I - USE prwf_I - USE orthsc_I - USE orbout_I - USE endsum_I + USE matrixmpi_I + USE newcompi_I + USE setlagmpi_I + USE improvmpi_I + USE maxarr_I + USE prwf_I + USE orthsc_I + USE orbout_I + USE endsum_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -64,13 +64,13 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL :: EOL - CHARACTER :: RWFFILE2*(*) + LOGICAL :: EOL + CHARACTER :: RWFFILE2*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J, I, NIT, JSEQ, KOUNT, K, L_MPI - REAL(DOUBLE) :: WTAEV, WTAEV0, DAMPMX + REAL(DOUBLE) :: WTAEV, WTAEV0, DAMPMX LOGICAL :: CONVG, LSORT, dvdfirst !----------------------------------------------- !CFF .. set the logical variable dvdfirst @@ -81,68 +81,68 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) L_MPI = MPI_LOGICAL ! if (ISIZE.EQ.8) L_MPI = MPI_LOGICAL8 - NCFTOT = NCF + NCFTOT = NCF !IF (myid .EQ. 0) PRINT *, '===SCF===' - + !======================================================================= ! Determine Orthonomalization order --- lsort !======================================================================= - - IF (NDEF == 0) THEN - LSORT = .FALSE. - ELSE + + IF (NDEF == 0) THEN + LSORT = .FALSE. + ELSE IF (myid .EQ. 0) THEN - 123 CONTINUE - WRITE (ISTDE, *) 'Orthonomalization order? ' - WRITE (ISTDE, *) ' 1 -- Update order' - WRITE (ISTDE, *) ' 2 -- Self consistency connected' - READ (ISTDI, *) J - IF (J == 1) THEN - LSORT = .FALSE. - ELSE IF (J == 2) THEN - LSORT = .TRUE. - ELSE - WRITE (ISTDE, *) 'Input is wrong, redo...' - GO TO 123 - ENDIF - ENDIF + 123 CONTINUE + WRITE (ISTDE, *) 'Orthonomalization order? ' + WRITE (ISTDE, *) ' 1 -- Update order' + WRITE (ISTDE, *) ' 2 -- Self consistency connected' + READ (ISTDI, *) J + IF (J == 1) THEN + LSORT = .FALSE. + ELSE IF (J == 2) THEN + LSORT = .TRUE. + ELSE + WRITE (ISTDE, *) 'Input is wrong, redo...' + GO TO 123 + ENDIF + ENDIF CALL MPI_Bcast (lsort, 1, L_MPI, 0, MPI_COMM_WORLD, ierr) - ENDIF - + ENDIF + !======================================================================= ! Deallocate storage that will no longer be used !======================================================================= - -!GG CALL DALLOC (JQSA, 'JQSA', 'SCFmpi') - + +!GG CALL DALLOC (JQSA, 'JQSA', 'SCFmpi') + !======================================================================= ! Allocate and fill in auxiliary arrays !======================================================================= - - CALL ALLOC (NCFPAST, NBLOCK, 'NCFPAST', 'SCFmpi') - CALL ALLOC (NCMINPAST, NBLOCK, 'NCMINPAST', 'SCFmpi') - CALL ALLOC (NEVECPAST, NBLOCK, 'NEVECPAST', 'SCFmpi') - CALL ALLOC (EAVBLK, NBLOCK, 'EAVBLK', 'SCFmpi') - - NCFPAST(1) = 0 - NCMINPAST(1) = 0 - NEVECPAST(1) = 0 - DO I = 2, NBLOCK - NCFPAST(I) = NCFPAST(I-1) + NCFBLK(I - 1) - NCMINPAST(I) = NCMINPAST(I-1) + NEVBLK(I - 1) - NEVECPAST(I) = NEVECPAST(I-1) + NEVBLK(I - 1)*NCFBLK(I - 1) - END DO - + + CALL ALLOC (NCFPAST, NBLOCK, 'NCFPAST', 'SCFmpi') + CALL ALLOC (NCMINPAST, NBLOCK, 'NCMINPAST', 'SCFmpi') + CALL ALLOC (NEVECPAST, NBLOCK, 'NEVECPAST', 'SCFmpi') + CALL ALLOC (EAVBLK, NBLOCK, 'EAVBLK', 'SCFmpi') + + NCFPAST(1) = 0 + NCMINPAST(1) = 0 + NEVECPAST(1) = 0 + DO I = 2, NBLOCK + NCFPAST(I) = NCFPAST(I-1) + NCFBLK(I - 1) + NCMINPAST(I) = NCMINPAST(I-1) + NEVBLK(I - 1) + NEVECPAST(I) = NEVECPAST(I-1) + NEVBLK(I - 1)*NCFBLK(I - 1) + END DO + !*** Size of the eigenvector array for all blocks - NVECSIZ = NEVECPAST(NBLOCK) + NEVBLK(NBLOCK)*NCFBLK(NBLOCK) - - IF (EOL) THEN - CALL ALLOC (EVAL, NCMIN, 'EVAL', 'SCFmpi') - CALL ALLOC (EVEC, NVECSIZ, 'EVEC', 'SCFmpi') - CALL ALLOC (IATJPO, NCMIN, 'IATJPO', 'SCFmpi') - CALL ALLOC (IASPAR, NCMIN, 'IASPAR', 'SCFmpi') - ENDIF - + NVECSIZ = NEVECPAST(NBLOCK) + NEVBLK(NBLOCK)*NCFBLK(NBLOCK) + + IF (EOL) THEN + CALL ALLOC (EVAL, NCMIN, 'EVAL', 'SCFmpi') + CALL ALLOC (EVEC, NVECSIZ, 'EVEC', 'SCFmpi') + CALL ALLOC (IATJPO, NCMIN, 'IATJPO', 'SCFmpi') + CALL ALLOC (IASPAR, NCMIN, 'IASPAR', 'SCFmpi') + ENDIF + !======================================================================= ! !======================================================================= @@ -159,165 +159,165 @@ SUBROUTINE SCFmpi(EOL, RWFFILE2) CALL ALLOC (XA, NXDIM, 'XA','SCFmpi') CALL ALLOC (NYA, NYDIM, 'NYA','SCFmpi') CALL ALLOC (YA, NYDIM, 'YA','SCFmpi') - + ! This call should only be made AFTER the call to newco ! CALL setlag (EOL) - + ! For (E)OL calculations, determine the level energies and ! mixing coefficients !CFF .. set the logical variable dvdfirst - IF (EOL) THEN + IF (EOL) THEN CALL MATRIXmpi (dvdfirst) - CALL NEWCOmpi (WTAEV) - ENDIF - WTAEV0 = 0.0 + CALL NEWCOmpi (WTAEV) + ENDIF + WTAEV0 = 0.0 dvdfirst = .false. - DO NIT = 1, NSCF - IF (MYID == 0) WRITE (*, 301) NIT - + DO NIT = 1, NSCF + IF (MYID == 0) WRITE (*, 301) NIT + ! For all pairs constrained through a Lagrange multiplier, compute ! the Lagrange multiplier - - CALL SETLAGmpi (EOL) - + + CALL SETLAGmpi (EOL) + ! Improve all orbitals in turn - - DAMPMX = 0.0 - IF (MYID == 0) WRITE (*, 302) - DO J = 1, NW - JSEQ = IORDER(J) - IF (LFIX(JSEQ)) CYCLE - CALL IMPROVmpi (EOL, JSEQ, LSORT, DAMPMX) - END DO + + DAMPMX = 0.0 + IF (MYID == 0) WRITE (*, 302) + DO J = 1, NW + JSEQ = IORDER(J) + IF (LFIX(JSEQ)) CYCLE + CALL IMPROVmpi (EOL, JSEQ, LSORT, DAMPMX) + END DO ! ! For KOUNT = 1 to NSIC: find the least self-consistent orbital; ! improve it ! ! write(istde,*) 'nsic=',nsic - DO KOUNT = 1, NSIC - CALL MAXARR (K) - IF (K == 0) THEN - CONVG = .TRUE. - GO TO 3 - ELSE - IF (SCNSTY(K) <= ACCY) THEN - CONVG = .TRUE. - GO TO 3 - ENDIF - ENDIF - CALL IMPROVmpi (EOL, K, LSORT, DAMPMX) - END DO - - CALL MAXARR (K) - - IF (K == 0) THEN - CONVG = .TRUE. - ELSE - IF (SCNSTY(K) <= ACCY) THEN - CONVG = .TRUE. - ELSE - CONVG = .FALSE. - ENDIF - ENDIF - - 3 CONTINUE - IF (LDBPR(24) .AND. MYID==0) CALL PRWF (0) - + DO KOUNT = 1, NSIC + CALL MAXARR (K) + IF (K == 0) THEN + CONVG = .TRUE. + GO TO 3 + ELSE + IF (SCNSTY(K) <= ACCY) THEN + CONVG = .TRUE. + GO TO 3 + ENDIF + ENDIF + CALL IMPROVmpi (EOL, K, LSORT, DAMPMX) + END DO + + CALL MAXARR (K) + + IF (K == 0) THEN + CONVG = .TRUE. + ELSE + IF (SCNSTY(K) <= ACCY) THEN + CONVG = .TRUE. + ELSE + CONVG = .FALSE. + ENDIF + ENDIF + + 3 CONTINUE + IF (LDBPR(24) .AND. MYID==0) CALL PRWF (0) + ! Perform Gram-Schmidt process ! For OL calculation, orthst is true and orbitals are orthonormalized ! in subroutine improv. For AL calculation, orthst is false. - IF (.NOT.ORTHST) CALL ORTHSC - + IF (.NOT.ORTHST) CALL ORTHSC + ! Write the subshell radial wavefunctions to the .rwf file - - IF (MYID == 0) CALL ORBOUT (RWFFILE2) - - IF (EOL) THEN + + IF (MYID == 0) CALL ORBOUT (RWFFILE2) + + IF (EOL) THEN CALL MATRIXmpi(dvdfirst) - CALL NEWCOmpi (WTAEV) - ENDIF + CALL NEWCOmpi (WTAEV) + ENDIF ! Make this a relative convergence test ! IF(ABS(WTAEV-WTAEV0).LT.1.0D-9.and. ! & DAMPMX.LT.1.0D-4) CONVG=.true. ! PRINT *, 'WTAEV, WTAEV0', WTAEV, WTAEV0, ! & ABS((WTAEV-WTAEV0)/WTAEV) -!GG IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE. +!GG IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE. !cjb unified convergence criteria in RMCDHF and RMCDHF_MPI !cjb IF(DABS(WTAEV-WTAEV0).LT.1.0D-8.and. & !cjb DAMPMX.LT.1.0D-2) CONVG=.true. IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE. - WTAEV0 = WTAEV - IF (.NOT.CONVG) CYCLE - IF (LDBPR(25) .AND. .NOT.LDBPR(24) .AND. MYID==0) CALL PRWF (0) + WTAEV0 = WTAEV + IF (.NOT.CONVG) CYCLE + IF (LDBPR(25) .AND. .NOT.LDBPR(24) .AND. MYID==0) CALL PRWF (0) !IF (EOL) CALL matrixmpi (dvdfirst) - GO TO 5 - - END DO - + GO TO 5 + + END DO + IF (MYID==0) WRITE (ISTDE,*)' Maximum iterations in SCF Exceeded.' - - 5 CONTINUE - DO I = 31, 32 + KMAXF - CLOSE(I) ! The MCP coefficient files - END DO - - IF (MYID == 0) THEN + + 5 CONTINUE + DO I = 31, 32 + KMAXF + CLOSE(I) ! The MCP coefficient files + END DO + + IF (MYID == 0) THEN !CLOSE (23) ! The .rwf file - CLOSE(25) ! The .mix file - ENDIF + CLOSE(25) ! The .mix file + ENDIF ! ! Complete the summary - moved from rscf92 for easier alloc/dalloc ! - IF (myid .EQ. 0) CALL ENDSUM + IF (myid .EQ. 0) CALL ENDSUM ! ! Deallocate storage ! - CALL DALLOC (WT, 'WT', 'SCFmpi') !Either getold or getald - - IF (NEC > 0) THEN - CALL DALLOC (IECC, 'IECC', 'SCFmpi') - CALL DALLOC (ECV, 'ECV', 'SCFmpi') - CALL DALLOC (IQA, 'IQA', 'SCFmpi') - ENDIF - - IF (NDDIM > 0) THEN - CALL DALLOC (DA, 'DA', 'SCFmpi') - CALL DALLOC (NDA, 'NDA', 'SCFmpi') + CALL DALLOC (WT, 'WT', 'SCFmpi') !Either getold or getald + + IF (NEC > 0) THEN + CALL DALLOC (IECC, 'IECC', 'SCFmpi') + CALL DALLOC (ECV, 'ECV', 'SCFmpi') + CALL DALLOC (IQA, 'IQA', 'SCFmpi') + ENDIF + + IF (NDDIM > 0) THEN + CALL DALLOC (DA, 'DA', 'SCFmpi') + CALL DALLOC (NDA, 'NDA', 'SCFmpi') NDDIM = 0 - ENDIF - - IF (NXDIM > 0) THEN - CALL DALLOC (XA, 'XA', 'SCFmpi') - CALL DALLOC (NXA, 'NXA', 'SCFmpi') + ENDIF + + IF (NXDIM > 0) THEN + CALL DALLOC (XA, 'XA', 'SCFmpi') + CALL DALLOC (NXA, 'NXA', 'SCFmpi') NXDIM = 0 - ENDIF - - IF (NYDIM > 0) THEN - CALL DALLOC (YA, 'YA', 'SCFmpi') - CALL DALLOC (NYA, 'NYA', 'SCFmpi') + ENDIF + + IF (NYDIM > 0) THEN + CALL DALLOC (YA, 'YA', 'SCFmpi') + CALL DALLOC (NYA, 'NYA', 'SCFmpi') NYDIM = 0 - ENDIF - - IF (EOL) THEN - CALL DALLOC (EVAL, 'EVAL', 'SCFmpi') - CALL DALLOC (EVEC, 'EvEC', 'SCFmpi') - CALL DALLOC (IATJPO, 'IATJPO', 'SCFmpi') - CALL DALLOC (IASPAR, 'IASPAR', 'SCFmpi') - CALL DALLOC (NCMAXBLK, 'NCMAXBLK', 'SCFmpi') ! getold.f - CALL DALLOC (EAVBLK, 'EAVBLK', 'SCFmpi') ! getold.f - CALL DALLOC (IDXBLK, 'IDXBLK', 'SCFmpi') ! Allocated in getold.f - CALL DALLOC (ICCMIN, 'ICCMIN', 'SCFmpi') ! Allocated in items.f<-getold.f - ENDIF + ENDIF + + IF (EOL) THEN + CALL DALLOC (EVAL, 'EVAL', 'SCFmpi') + CALL DALLOC (EVEC, 'EvEC', 'SCFmpi') + CALL DALLOC (IATJPO, 'IATJPO', 'SCFmpi') + CALL DALLOC (IASPAR, 'IASPAR', 'SCFmpi') + CALL DALLOC (NCMAXBLK, 'NCMAXBLK', 'SCFmpi') ! getold.f + CALL DALLOC (EAVBLK, 'EAVBLK', 'SCFmpi') ! getold.f + CALL DALLOC (IDXBLK, 'IDXBLK', 'SCFmpi') ! Allocated in getold.f + CALL DALLOC (ICCMIN, 'ICCMIN', 'SCFmpi') ! Allocated in items.f<-getold.f + ENDIF ! - CALL DALLOC (NCFPAST, 'NCFPAST', 'SCFmpi') - CALL DALLOC (NCMINPAST, 'NCMINPAST', 'SCFmpi') - CALL DALLOC (NEVECPAST, 'NEVECPAST', 'SCFmpi') - - 301 FORMAT(/,' Iteration number ',1I3,/,' --------------------') + CALL DALLOC (NCFPAST, 'NCFPAST', 'SCFmpi') + CALL DALLOC (NCMINPAST, 'NCMINPAST', 'SCFmpi') + CALL DALLOC (NEVECPAST, 'NEVECPAST', 'SCFmpi') + + 301 FORMAT(/,' Iteration number ',1I3,/,' --------------------') 302 FORMAT(41X,'Self- Damping'/,& 'Subshell Energy Method P0 ',& - 'consistency Norm-1 factor JP',' MTP INV NNP'/) - - RETURN + 'consistency Norm-1 factor JP',' MTP INV NNP'/) + + RETURN END SUBROUTINE SCFmpi diff --git a/src/appl/rmcdhf90_mpi/scfmpi_I.f90 b/src/appl/rmcdhf90_mpi/scfmpi_I.f90 index 84bd44051..c5cb08c15 100644 --- a/src/appl/rmcdhf90_mpi/scfmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/scfmpi_I.f90 @@ -1,11 +1,11 @@ - MODULE scfmpi_I + MODULE scfmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE scfmpi (EOL, RWFFILE2) - LOGICAL, INTENT(IN) :: EOL - CHARACTER (LEN = *) :: RWFFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE scfmpi (EOL, RWFFILE2) + LOGICAL, INTENT(IN) :: EOL + CHARACTER (LEN = *) :: RWFFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setcof.f90 b/src/appl/rmcdhf90_mpi/setcof.f90 index e9bcbd6c7..2aa1fcda1 100644 --- a/src/appl/rmcdhf90_mpi/setcof.f90 +++ b/src/appl/rmcdhf90_mpi/setcof.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCOF(EOL, J) + SUBROUTINE SETCOF(EOL, J) ! * ! This subroutine sets up the coefficients and orbital pointers * ! for the direct and exchange potentials for orbital J . It also * @@ -14,20 +14,20 @@ SUBROUTINE SETCOF(EOL, J) ! Modified by Xinghong He Last update: 21 Dec 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE orb_C USE hblock_C USE hmat_C USE iounit_C - USE MCPA_C + USE MCPA_C USE mpi_C USE pos_C USE scf_C @@ -35,31 +35,31 @@ SUBROUTINE SETCOF(EOL, J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dsubrs_I - USE fco_I - USE gco_I + USE dsubrs_I + USE fco_I + USE gco_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - LOGICAL :: EOL + INTEGER :: J + LOGICAL :: EOL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB - CHARACTER*6, PARAMETER :: MYNAME = 'SETCOF' + INTEGER, PARAMETER :: KEY = KEYORB + CHARACTER*6, PARAMETER :: MYNAME = 'SETCOF' REAL, PARAMETER :: EPS = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(4) :: INDEXS + INTEGER , DIMENSION(4) :: INDEXS INTEGER :: NDIM, NAKJ, NKJJ, ILABEL, NWTERM, IB, K, NB, IR, NKJIB, KMAX, & KMIN, NFILE, I, JBLOCK, JBLOCKT, IENDCDUM, NCOEFF, IOS, LAB, NCONTR, & IA, IC, ITHIS, IRANK, IIND, IL, IORB, IYO1, IYO2, IFOUND, LOC1, LOC2, & ITHIS2, INDIND, NELMNTGG - REAL(DOUBLE) :: UCFJ, SUMR, YKAB, XKAB, SUM, CONTR - CHARACTER :: MCPLAB*3, IDSTRING*3, MSG*128 + REAL(DOUBLE) :: UCFJ, SUMR, YKAB, XKAB, SUM, CONTR + CHARACTER :: MCPLAB*3, IDSTRING*3, MSG*128 !----------------------------------------------- !** Locals ! POINTER (PCOEFF,COEFF(1)) @@ -94,56 +94,56 @@ SUBROUTINE SETCOF(EOL, J) !======================================================================= ! Initializations !======================================================================= - - NDIM = 1 - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - - NDCOF = 0 - NXCOF = 0 - NYCOF = 0 - - NAKJ = NAK(J) - NKJJ = NKJ(J) - UCFJ = UCF(J) - + + NDIM = 1 + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + + NDCOF = 0 + NXCOF = 0 + NYCOF = 0 + + NAKJ = NAK(J) + NKJJ = NKJ(J) + UCFJ = UCF(J) + !======================================================================= ! Generate YA coefficients that do not require MCP output list. ! Computation distributed and then collected. !======================================================================= - - ILABEL = 0 - NWTERM = KEY*(KEY + 1) - DO IB = 1, NW - ILABEL = ILABEL + NWTERM - IF (IB == J) THEN - KMAX = NKJJ - 1 - ELSE - KMAX = 0 - ENDIF - DO K = 0, KMAX, 2 - + + ILABEL = 0 + NWTERM = KEY*(KEY + 1) + DO IB = 1, NW + ILABEL = ILABEL + NWTERM + IF (IB == J) THEN + KMAX = NKJJ - 1 + ELSE + KMAX = 0 + ENDIF + DO K = 0, KMAX, 2 + !<<< mpi distribute calculation <<<<<<<<<<<<<<<<<<<<<< - SUMR = 0.D0 - DO NB = 1, NBLOCK - DO IR = MYID + 1, NCFBLK(NB), NPROCS + SUMR = 0.D0 + DO NB = 1, NBLOCK + DO IR = MYID + 1, NCFBLK(NB), NPROCS SUMR = SUMR + DSUBRS(EOL,IR,IR,NB)*FCO(K,IR + NCFPAST(NB),J,& - IB) - END DO - END DO + IB) + END DO + END DO !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - IF (IB == J) THEN - YKAB = 2.D0*SUMR/UCFJ - ELSE - YKAB = SUMR/UCFJ - ENDIF - + + IF (IB == J) THEN + YKAB = 2.D0*SUMR/UCFJ + ELSE + YKAB = SUMR/UCFJ + ENDIF + !*** The following IF has to be removed since YKAB !*** is incomplete in multiprocessor case !IF (ABS (YKAB) .GT. EPS) THEN - NYCOF = NYCOF + 1 + NYCOF = NYCOF + 1 IF (NYCOF .GT. NYDIM ) THEN IF (NYDIM .GT. 0) THEN NYDIM = 2*NYDIM @@ -153,401 +153,401 @@ SUBROUTINE SETCOF(EOL, J) NYDIM = 64 CALL ALLOC(NYA, NYDIM, 'NYA', 'SETCOF') CALL ALLOC(YA, NYDIM, 'YA', 'SETCOF') - ENDIF - ENDIF - YA(NYCOF) = YKAB - NYA(NYCOF) = K + ILABEL + ENDIF + ENDIF + YA(NYCOF) = YKAB + NYA(NYCOF) = K + ILABEL !ENDIF - - END DO - END DO - + + END DO + END DO + !======================================================================= ! Generate XA coefficients that do not require MCP output list ! Computation distributed and then collected. !======================================================================= - - ILABEL = KEY*J - NWTERM = KEY*KEY*(KEY + 1) - DO IB = 1, NW - ILABEL = ILABEL + NWTERM - IF (IB == J) CYCLE - NKJIB = NKJ(IB) - IF (NAKJ*NAK(IB) > 0) THEN - KMIN = ABS((NKJJ - NKJIB)/2) - ELSE - KMIN = ABS((NKJJ - NKJIB)/2) + 1 - ENDIF - KMAX = (NKJJ + NKJIB)/2 - - DO K = KMIN, KMAX, 2 - + + ILABEL = KEY*J + NWTERM = KEY*KEY*(KEY + 1) + DO IB = 1, NW + ILABEL = ILABEL + NWTERM + IF (IB == J) CYCLE + NKJIB = NKJ(IB) + IF (NAKJ*NAK(IB) > 0) THEN + KMIN = ABS((NKJJ - NKJIB)/2) + ELSE + KMIN = ABS((NKJJ - NKJIB)/2) + 1 + ENDIF + KMAX = (NKJJ + NKJIB)/2 + + DO K = KMIN, KMAX, 2 + !<<< mpi distribute calculation <<<<<<<<<<<<<<<<<<<<<< - SUMR = 0.D0 - DO NB = 1, NBLOCK - DO IR = MYID + 1, NCFBLK(NB), NPROCS + SUMR = 0.D0 + DO NB = 1, NBLOCK + DO IR = MYID + 1, NCFBLK(NB), NPROCS SUMR = SUMR + DSUBRS(EOL,IR,IR,NB)*GCO(K,IR + NCFPAST(NB),J,& - IB) - END DO - END DO + IB) + END DO + END DO !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - XKAB = SUMR/UCFJ - + + XKAB = SUMR/UCFJ + !*** The following IF has to be removed since YKAB !*** is incomplete in multiprocessor case !IF (ABS (XKAB) .GT. EPS) THEN - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ENDIF - ENDIF - XA(NXCOF) = XKAB - NXA(NXCOF) = K + ILABEL + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ENDIF + ENDIF + XA(NXCOF) = XKAB + NXA(NXCOF) = K + ILABEL !ENDIF - END DO - END DO - + END DO + END DO + !======================================================================= ! Subroutine setham called from matrix had gone through the mcp ! files once. setcof will do it again. (Go to setmcp to see ! contents of these records. !======================================================================= - - DO NFILE = 30, 32 + KMAXF - REWIND (NFILE) - IF (NFILE /= 30) THEN - DO I = 1, 3 - READ (NFILE) - CYCLE - END DO - ELSE - DO I = 1, 3 - READ (NFILE) - READ (NFILE) - END DO - ENDIF - END DO - + + DO NFILE = 30, 32 + KMAXF + REWIND (NFILE) + IF (NFILE /= 30) THEN + DO I = 1, 3 + READ (NFILE) + CYCLE + END DO + ELSE + DO I = 1, 3 + READ (NFILE) + READ (NFILE) + END DO + ENDIF + END DO + !======================================================================= ! Generate DA coefficients; these arise from the one-electron ! integrals !======================================================================= - - DO JBLOCK = 1, NBLOCK - + + DO JBLOCK = 1, NBLOCK + !*** Read in IROW from file mcp.30 *** - READ (30) MCPLAB, JBLOCKT, NCF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, '1: jblockt .NE. jblock' - STOP - ENDIF + READ (30) MCPLAB, JBLOCKT, NCF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, '1: jblockt .NE. jblock' + STOP + ENDIF READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') - READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - + CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') + READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + !*** Block info file mcp.31 *** - READ (31) MCPLAB, JBLOCKT, NCF, NCOEFF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, '2: jblockt .NE. jblock' - STOP - ENDIF - + READ (31) MCPLAB, JBLOCKT, NCF, NCOEFF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, '2: jblockt .NE. jblock' + STOP + ENDIF + !*** Loop over labels having non-zero coefficients !*** it exits when no more labels for the block - - L123: DO WHILE(.TRUE.) - READ (31, IOSTAT=IOS) LAB, NCONTR - + + L123: DO WHILE(.TRUE.) + READ (31, IOSTAT=IOS) LAB, NCONTR + ! 0, 0 marks the end of a block. This is the normal exit - - IF (LAB==0 .AND. NCONTR==0) THEN - CALL DALLOC (IROW, 'IROW', 'SETCOF') - EXIT ! Actually to next block - ENDIF - + + IF (LAB==0 .AND. NCONTR==0) THEN + CALL DALLOC (IROW, 'IROW', 'SETCOF') + EXIT ! Actually to next block + ENDIF + !*** Decode the labels of I(ab) *** - IA = MOD(LAB,KEY) - IB = LAB/KEY - + IA = MOD(LAB,KEY) + IB = LAB/KEY + ! At least one orbital should be J in order to have ! non-zero value; otherwise, goto next label. - - IF (IA/=J .AND. IB/=J) THEN - READ (31) ! No contributions from this integral; skip - CYCLE ! to next label - ENDIF - - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - ENDIF - + + IF (IA/=J .AND. IB/=J) THEN + READ (31) ! No contributions from this integral; skip + CYCLE ! to next label + ENDIF + + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF' ) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + ENDIF + ! Read the column index, the sparse matrix index, and the ! coefficient for all contributions from this integral - - READ (31) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) - + + READ (31) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) + ! Add up all the contributions from this integral; ! off-diagonal contributions have double the weight - - SUM = 0.D0 - DO I = 1, NCONTR - IR = IROW(INDX(I)) - IC = ICLMN(I) - - CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) - - IF (IR /= IC) CONTR = CONTR + CONTR - SUM = SUM + CONTR - END DO - SUM = 0.5D0*SUM/UCFJ - + + SUM = 0.D0 + DO I = 1, NCONTR + IR = IROW(INDX(I)) + IC = ICLMN(I) + + CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) + + IF (IR /= IC) CONTR = CONTR + CONTR + SUM = SUM + CONTR + END DO + SUM = 0.5D0*SUM/UCFJ + ! Put coefficients in the list. Since there is always ! (almost) some repeatence from different blocks, a check ! and merge is performed. This will significantly reduce ! the NDCOF and thus the number of calls to YZK later. - + !*** Find the right counting parameter *** - IF (IA == J) THEN - ITHIS = IB - ELSE - ITHIS = IA - ENDIF - + IF (IA == J) THEN + ITHIS = IB + ELSE + ITHIS = IA + ENDIF + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NDCOF - IF (NDA(I) /= ITHIS) CYCLE ! found, add the value - DA(I) = DA(I) + SUM - CYCLE L123 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NDCOF + IF (NDA(I) /= ITHIS) CYCLE ! found, add the value + DA(I) = DA(I) + SUM + CYCLE L123 + END DO + ENDIF + !*** Not found in the record, add an item *** - NDCOF = NDCOF + 1 - IF (NDCOF > NDDIM) THEN - IF (NDDIM > 0) THEN + NDCOF = NDCOF + 1 + IF (NDCOF > NDDIM) THEN + IF (NDDIM > 0) THEN NDDIM = 2*NDDIM - CALL RALLOC (DA, NDDIM, 'DA', 'SETCOF') - CALL RALLOC (NDA, NDDIM, 'NDA', 'SETCOF') - ELSE + CALL RALLOC (DA, NDDIM, 'DA', 'SETCOF') + CALL RALLOC (NDA, NDDIM, 'NDA', 'SETCOF') + ELSE NDDIM = 64 - CALL ALLOC (DA, NDDIM, 'DA', 'SETCOF') - CALL ALLOC (NDA, NDDIM, 'NDA', 'SETCOF') - ENDIF - ENDIF - DA(NDCOF) = SUM ! print*, DA(NDCOF), ndcof, myid, 'myid' - NDA(NDCOF) = ITHIS - - END DO L123 ! For labels - END DO ! For blocks - + CALL ALLOC (DA, NDDIM, 'DA', 'SETCOF') + CALL ALLOC (NDA, NDDIM, 'NDA', 'SETCOF') + ENDIF + ENDIF + DA(NDCOF) = SUM ! print*, DA(NDCOF), ndcof, myid, 'myid' + NDA(NDCOF) = ITHIS + + END DO L123 ! For labels + END DO ! For blocks + !======================================================================= ! Generate YA and XA coefficients; these arise from the two-electron ! integrals !======================================================================= - - DO NFILE = 32, 32 + KMAXF - + + DO NFILE = 32, 32 + KMAXF + ! ...Re-position file mcp.30 - - REWIND (30) - DO I = 1, 6 - READ (30) - END DO - + + REWIND (30) + DO I = 1, 6 + READ (30) + END DO + !======================================================================= ! Loop over blocks again, this time, for V-coefficients !======================================================================= - - DO JBLOCK = 1, NBLOCK + + DO JBLOCK = 1, NBLOCK ! ...Read in IROW from file mcp.30 - READ (30) MCPLAB, JBLOCKT, NCF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ':3 jblockt .NE. jblock' - STOP - ENDIF + READ (30) MCPLAB, JBLOCKT, NCF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ':3 jblockt .NE. jblock' + STOP + ENDIF READ (30) NELMNTGG NELMNT = INT8(NELMNTGG) - CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') - READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) - - READ (NFILE) MCPLAB, JBLOCKT, NCF, NCOEFF - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ':4 jblockt .NE. jblock' - STOP - ENDIF - - K = NFILE - 32 ! multipolarity of the integral - + CALL ALLOC (IROW, NELMNT, 'IROW', 'SETCOF') + READ (30) (IENDCDUM,I=MYID + 1,NCF,NPROCS), (IROW(I),I=1,NELMNT) + + READ (NFILE) MCPLAB, JBLOCKT, NCF, NCOEFF + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ':4 jblockt .NE. jblock' + STOP + ENDIF + + K = NFILE - 32 ! multipolarity of the integral + !======================================================================= ! Attempt to read another block of data !======================================================================= - - 999 CONTINUE - READ (NFILE, IOSTAT=IOS) LAB, NCONTR + + 999 CONTINUE + READ (NFILE, IOSTAT=IOS) LAB, NCONTR ! - IF (LAB==0 .AND. NCONTR==0) THEN - CALL DALLOC (IROW, 'IROW', 'SETCOF') - CYCLE - ENDIF + IF (LAB==0 .AND. NCONTR==0) THEN + CALL DALLOC (IROW, 'IROW', 'SETCOF') + CYCLE + ENDIF !*** k !*** Decode the labels of R (abcd) - INDEXS(4) = MOD(LAB,KEY) - LAB = LAB/KEY - INDEXS(2) = MOD(LAB,KEY) - LAB = LAB/KEY - INDEXS(3) = MOD(LAB,KEY) - INDEXS(1) = LAB/KEY - + INDEXS(4) = MOD(LAB,KEY) + LAB = LAB/KEY + INDEXS(2) = MOD(LAB,KEY) + LAB = LAB/KEY + INDEXS(3) = MOD(LAB,KEY) + INDEXS(1) = LAB/KEY + !*** Determine the number of indices that match - IRANK = 0 - IRANK = IRANK + COUNT(INDEXS==J) - - IF (IRANK == 0) THEN - READ (NFILE) - GO TO 999 - ENDIF - + IRANK = 0 + IRANK = IRANK + COUNT(INDEXS==J) + + IF (IRANK == 0) THEN + READ (NFILE) + GO TO 999 + ENDIF + !*** At least one subshell index matches; allocate storage !*** for reading in the rest of this block - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF') - CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') - ENDIF - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETCOF') + CALL ALLOC (ICLMN, NDIM, 'ICLMN', 'SETCOF') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETCOF') + ENDIF + !*** Read column index, sparse matrix index, and !*** coefficient for all contributions from this integral - READ (NFILE) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) - + READ (NFILE) (ICLMN(I),INDX(I),COEFF(I),I=1,NCONTR) + !*** Add up all the contributions from this integral; !*** off-diagonal contributions have double the weight - SUM = 0.D0 - DO I = 1, NCONTR - IR = IROW(INDX(I)) - IC = ICLMN(I) - CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) - IF (IR /= IC) CONTR = CONTR + CONTR - SUM = SUM + CONTR - END DO - SUM = 0.5D0*SUM/UCFJ - - SELECT CASE (IRANK) - CASE (1) - + SUM = 0.D0 + DO I = 1, NCONTR + IR = IROW(INDX(I)) + IC = ICLMN(I) + CONTR = DSUBRS(EOL,IR,IC,JBLOCK)*COEFF(I) + IF (IR /= IC) CONTR = CONTR + CONTR + SUM = SUM + CONTR + END DO + SUM = 0.5D0*SUM/UCFJ + + SELECT CASE (IRANK) + CASE (1) + !======================================================================= ! One matching index: exchange potential contribution !======================================================================= - + !*** Similar to DA, find ithis *** - ITHIS = -911 ! initialize to an impossible value + ITHIS = -911 ! initialize to an impossible value ! though not necessary - DO IIND = 1, 4 - IF (INDEXS(IIND) /= J) CYCLE ! at least one - IL = IIND + 2 - IF (IL > 4) IL = IL - 4 - IORB = INDEXS(IL) - IL = IIND + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - IL = IIND + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - EXIT - END DO - - IF (ITHIS == (-911)) STOP 'ithis .EQ. -911' - + DO IIND = 1, 4 + IF (INDEXS(IIND) /= J) CYCLE ! at least one + IL = IIND + 2 + IF (IL > 4) IL = IL - 4 + IORB = INDEXS(IL) + IL = IIND + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + IL = IIND + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + EXIT + END DO + + IF (ITHIS == (-911)) STOP 'ithis .EQ. -911' + !*** Check ithis against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS) CYCLE - XA(I) = XA(I) + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS) CYCLE + XA(I) = XA(I) + SUM + GO TO 999 + END DO + ENDIF + !*** Not found in records, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ENDIF - ENDIF - XA(NXCOF) = SUM - NXA(NXCOF) = ITHIS - - CASE (2) - + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ENDIF + ENDIF + XA(NXCOF) = SUM + NXA(NXCOF) = ITHIS + + CASE (2) + !======================================================================= ! Two matching indices: either direct or exchange potential ! contribution !======================================================================= - - IFOUND = 0 - DO IIND = 1, 4 - IF (INDEXS(IIND) /= J) CYCLE - IF (IFOUND == 0) THEN - LOC1 = IIND - IFOUND = IFOUND + 1 - ELSE IF (IFOUND == 1) THEN - LOC2 = IIND - EXIT - ENDIF - END DO - - IF (LOC2 - LOC1 == 2) THEN + + IFOUND = 0 + DO IIND = 1, 4 + IF (INDEXS(IIND) /= J) CYCLE + IF (IFOUND == 0) THEN + LOC1 = IIND + IFOUND = IFOUND + 1 + ELSE IF (IFOUND == 1) THEN + LOC2 = IIND + EXIT + ENDIF + END DO + + IF (LOC2 - LOC1 == 2) THEN ! ! Direct contribution ! !*** Find ithis *** - IL = LOC1 + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - IL = LOC1 + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - ITHIS = (IYO2*KEY + IYO1)*KEY + K - + IL = LOC1 + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + IL = LOC1 + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + ITHIS = (IYO2*KEY + IYO1)*KEY + K + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + SUM + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + SUM + SUM + GO TO 999 + END DO + ENDIF + !*** Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM CALL RALLOC(NYA, NYDIM, 'NYA', 'SETCOF') CALL RALLOC(YA, NYDIM, 'YA', 'SETCOF') @@ -555,153 +555,153 @@ SUBROUTINE SETCOF(EOL, J) NYDIM = 64 CALL ALLOC(NYA, NYDIM, 'NYA', 'SETCOF 2b') CALL ALLOC(YA, NYDIM, 'YA', 'SETCOF') - ENDIF - ENDIF - YA(NYCOF) = SUM + SUM - NYA(NYCOF) = ITHIS - - ELSE + ENDIF + ENDIF + YA(NYCOF) = SUM + SUM + NYA(NYCOF) = ITHIS + + ELSE ! ! Exchange contribution ! !*** Find ithis *** - IL = LOC1 + 2 - IF (IL > 4) IL = IL - 4 - IORB = INDEXS(IL) - IL = LOC1 + 1 - IF (IL > 4) IL = IL - 4 - IYO1 = INDEXS(IL) - IL = LOC1 + 3 - IF (IL > 4) IL = IL - 4 - IYO2 = INDEXS(IL) - ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - + IL = LOC1 + 2 + IF (IL > 4) IL = IL - 4 + IORB = INDEXS(IL) + IL = LOC1 + 1 + IF (IL > 4) IL = IL - 4 + IYO1 = INDEXS(IL) + IL = LOC1 + 3 + IF (IL > 4) IL = IL - 4 + IYO2 = INDEXS(IL) + ITHIS = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + !*** Check it against the previously recorded *** - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS) CYCLE - XA(I) = XA(I) + SUM + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS) CYCLE + XA(I) = XA(I) + SUM + SUM + GO TO 999 + END DO + ENDIF + !*** Not found, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ENDIF - ENDIF - XA(NXCOF) = SUM + SUM - NXA(NXCOF) = ITHIS - - ENDIF - - CASE (3) - + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ENDIF + ENDIF + XA(NXCOF) = SUM + SUM + NXA(NXCOF) = ITHIS + + ENDIF + + CASE (3) + !======================================================================= ! Three matching indices: direct and exchange potential contributions !======================================================================= - + !*** Find ithis AND ithis2 - ITHIS = -911 - ITHIS2 = -911 - DO IIND = 1, 4 - IF (INDEXS(IIND) == J) CYCLE - INDIND = INDEXS(IIND) - IYO2 = INDIND - IYO1 = J - ITHIS = (IYO2*KEY + IYO1)*KEY + K - IORB = INDIND - IYO1 = J - IYO2 = J - ITHIS2 = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K - END DO - - IF (ITHIS==(-911) .OR. ITHIS2==(-911)) STOP 'ithis2' - + ITHIS = -911 + ITHIS2 = -911 + DO IIND = 1, 4 + IF (INDEXS(IIND) == J) CYCLE + INDIND = INDEXS(IIND) + IYO2 = INDIND + IYO1 = J + ITHIS = (IYO2*KEY + IYO1)*KEY + K + IORB = INDIND + IYO1 = J + IYO2 = J + ITHIS2 = ((IORB*KEY + IYO2)*KEY + IYO1)*KEY + K + END DO + + IF (ITHIS==(-911) .OR. ITHIS2==(-911)) STOP 'ithis2' + !*** Check the previously recorded for YA - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + SUM + SUM - GO TO 456 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + SUM + SUM + GO TO 456 + END DO + ENDIF + ! Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM CALL RALLOC (NYA, NYDIM, 'NYA', 'SETCOF') CALL RALLOC (YA, NYDIM, 'YA', 'SETCOF') - ELSE + ELSE NYDIM = 64 CALL ALLOC (NYA, NYDIM, 'NYA', 'SETCOF') CALL ALLOC (YA, NYDIM, 'YA', 'SETCOF') - ENDIF - ENDIF - YA(NYCOF) = SUM + SUM - NYA(NYCOF) = ITHIS - - 456 CONTINUE - + ENDIF + ENDIF + YA(NYCOF) = SUM + SUM + NYA(NYCOF) = ITHIS + + 456 CONTINUE + !*** Check the previously recorded for XA - IF (JBLOCK > 1) THEN - DO I = 1, NXCOF - IF (NXA(I) /= ITHIS2) CYCLE - XA(I) = XA(I) + SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NXCOF + IF (NXA(I) /= ITHIS2) CYCLE + XA(I) = XA(I) + SUM + GO TO 999 + END DO + ENDIF + ! Not found, add an item *** - NXCOF = NXCOF + 1 - IF (NXCOF > NXDIM) THEN - IF (NXDIM > 0) THEN + NXCOF = NXCOF + 1 + IF (NXCOF > NXDIM) THEN + IF (NXDIM > 0) THEN NXDIM = 2*NXDIM - CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ELSE + CALL RALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL RALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ELSE NXDIM = 64 - CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') - CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') - ENDIF - ENDIF - XA(NXCOF) = SUM - NXA(NXCOF) = ITHIS2 - - CASE (4) - + CALL ALLOC (XA, NXDIM, 'XA', 'SETCOF') + CALL ALLOC (NXA, NXDIM, 'NXA', 'SETCOF') + ENDIF + ENDIF + XA(NXCOF) = SUM + NXA(NXCOF) = ITHIS2 + + CASE (4) + !======================================================================= ! Four matching indices: direct potential contribution !======================================================================= - + !*** Find ithis AND ithis2 - IYO2 = J - IYO1 = J - ITHIS = (IYO2*KEY + IYO1)*KEY + K - + IYO2 = J + IYO1 = J + ITHIS = (IYO2*KEY + IYO1)*KEY + K + !*** Check the previously recorded for YA - IF (JBLOCK > 1) THEN - DO I = 1, NYCOF - IF (NYA(I) /= ITHIS) CYCLE - YA(I) = YA(I) + 4.D0*SUM - GO TO 999 - END DO - ENDIF - + IF (JBLOCK > 1) THEN + DO I = 1, NYCOF + IF (NYA(I) /= ITHIS) CYCLE + YA(I) = YA(I) + 4.D0*SUM + GO TO 999 + END DO + ENDIF + ! Not found, add an item *** - NYCOF = NYCOF + 1 - IF (NYCOF > NYDIM) THEN - IF (NYDIM > 0) THEN + NYCOF = NYCOF + 1 + IF (NYCOF > NYDIM) THEN + IF (NYDIM > 0) THEN NYDIM = 2*NYDIM CALL RALLOC(NYA, NYDIM, 'NYA', 'SETCOF') CALL RALLOC(YA, NYDIM, 'YA', 'SETCOF') @@ -709,23 +709,23 @@ SUBROUTINE SETCOF(EOL, J) NYDIM = 64 CALL ALLOC(NYA, NYDIM, 'NYA', 'SETCOF 4b') CALL ALLOC(YA, NYDIM, 'YA', 'SETCOF') - ENDIF - ENDIF - YA(NYCOF) = 4.D0*SUM - NYA(NYCOF) = ITHIS - - END SELECT - - GO TO 999 - END DO ! loop for V-Coefficients - END DO - + ENDIF + ENDIF + YA(NYCOF) = 4.D0*SUM + NYA(NYCOF) = ITHIS + + END SELECT + + GO TO 999 + END DO ! loop for V-Coefficients + END DO + !======================================================================= ! Deallocate storage for arrays local to this routine !======================================================================= - CALL DALLOC (COEFF, 'COEFF', 'SETCOF') - CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') - CALL DALLOC (INDX, 'INDX', 'SETCOF') - - RETURN - END SUBROUTINE SETCOF + CALL DALLOC (COEFF, 'COEFF', 'SETCOF') + CALL DALLOC (ICLMN, 'ICLMN', 'SETCOF') + CALL DALLOC (INDX, 'INDX', 'SETCOF') + + RETURN + END SUBROUTINE SETCOF diff --git a/src/appl/rmcdhf90_mpi/setcof_I.f90 b/src/appl/rmcdhf90_mpi/setcof_I.f90 index 71156324b..f43973acb 100644 --- a/src/appl/rmcdhf90_mpi/setcof_I.f90 +++ b/src/appl/rmcdhf90_mpi/setcof_I.f90 @@ -1,11 +1,11 @@ - MODULE setcof_I + MODULE setcof_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:21:02 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcof (EOL, J) - LOGICAL :: EOL - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcof (EOL, J) + LOGICAL :: EOL + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setcslmpi.f90 b/src/appl/rmcdhf90_mpi/setcslmpi.f90 index 8dcda5b5f..160661fc4 100644 --- a/src/appl/rmcdhf90_mpi/setcslmpi.f90 +++ b/src/appl/rmcdhf90_mpi/setcslmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) + SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) ! ! A container which calls lib92/lodcsh to get ! ncore, nelec, nw, np(), nak(), nkl(), nkj(), nh() @@ -18,13 +18,13 @@ SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) ! JCUPA(NNNWP*NCF) * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE hblock_C @@ -35,20 +35,20 @@ SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslmpiGG_I + USE openfl_I + USE lodcslmpiGG_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - CHARACTER :: NAME*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: NCORE + CHARACTER :: NAME*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IOS - CHARACTER :: STR*15 + INTEGER :: IOS + CHARACTER :: STR*15 !----------------------------------------------- ! ! node-0 opens, reads the header of the file @@ -67,9 +67,9 @@ SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) CLOSE (21) STOP ENDIF - + !..Load header of file - CALL LODCSH (21, NCORE) + CALL LODCSH (21, NCORE) END IF ! Broadcast results to other nodes. ncfblk should be allocated @@ -83,16 +83,16 @@ SUBROUTINE SETCSLmpi(NAME, NCORE, IDBLK) CALL MPI_Bcast (nkl(1),nw, MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (nkj(1),nw, MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (nh(1),2*nw, MPI_CHARACTER,0,MPI_COMM_WORLD,ierr) - + ! Allocate memories for all blocks and then load the entire file CALL ALLOC (iqa, NNNW, NCFTOT, 'IQA', 'SETCSLmpi') !GG CALL ALLOC (jqsa, NNNW,3,NCFTOT, 'JQSA', 'SETCSmpiL') !GG CALL ALLOC (jcupa, NNNW, NCFTOT, 'JCUPA', 'SETCSLmpi') -!GG CALL LODCSLmpi (21, NCORE, -119) - CALL LODCSLmpiGG (21, NCORE, -119) +!GG CALL LODCSLmpi (21, NCORE, -119) + CALL LODCSLmpiGG (21, NCORE, -119) ! -119 means "load all blocks" - - RETURN + + RETURN END SUBROUTINE SETCSLmpi diff --git a/src/appl/rmcdhf90_mpi/setcslmpi_I.f90 b/src/appl/rmcdhf90_mpi/setcslmpi_I.f90 index 516dd08d4..94d1320bb 100644 --- a/src/appl/rmcdhf90_mpi/setcslmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/setcslmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE setcslmpi_I + MODULE setcslmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcslmpi (NAME, NCORE, IDBLK) - CHARACTER (LEN = *), INTENT(IN) :: NAME - INTEGER :: NCORE - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + SUBROUTINE setcslmpi (NAME, NCORE, IDBLK) + CHARACTER (LEN = *), INTENT(IN) :: NAME + INTEGER :: NCORE + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK !VAST...Dummy argument IDBLK is not referenced in this routine. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setdbg.f90 b/src/appl/rmcdhf90_mpi/setdbg.f90 index c46a0cebd..7fc0e1a99 100644 --- a/src/appl/rmcdhf90_mpi/setdbg.f90 +++ b/src/appl/rmcdhf90_mpi/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG(DBGFILE) + SUBROUTINE SETDBG(DBGFILE) ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -11,20 +11,20 @@ SUBROUTINE SETDBG(DBGFILE) ! Modified bu Xinghong He Last update: 06 Jul 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE DEBUG_C + USE DEBUG_C USE default_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I + USE getyn_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -33,117 +33,117 @@ SUBROUTINE SETDBG(DBGFILE) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' - CHARACTER*3, PARAMETER :: STATUS = 'NEW' + CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' + CHARACTER*3, PARAMETER :: STATUS = 'NEW' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, LENDBG, LENFIL, IERR -!GG CHARACTER(LEN=120) :: FILNAM - CHARACTER(LEN = LEN (dbgfile)) :: FILNAM + INTEGER :: I, LENDBG, LENFIL, IERR +!GG CHARACTER(LEN=120) :: FILNAM + CHARACTER(LEN = LEN (dbgfile)) :: FILNAM !----------------------------------------------- ! ! Initialise the arrays that control the debug printout ! These serve as the default settings. ! - LDBPA = .FALSE. - LDBPG = .FALSE. - - LDBPR = .FALSE. + LDBPA = .FALSE. + LDBPG = .FALSE. + + LDBPR = .FALSE. ! - IF (NDEF == 0) RETURN - + IF (NDEF == 0) RETURN + ! Even in non-default, the user can choose not to have debug ! print-out - - WRITE (ISTDE, '(A)') 'Generate debug output? (y/n) ' - IF (.NOT.GETYN()) RETURN - - LENDBG = LEN_TRIM(DBGFILE) - + + WRITE (ISTDE, '(A)') 'Generate debug output? (y/n) ' + IF (.NOT.GETYN()) RETURN + + LENDBG = LEN_TRIM(DBGFILE) + WRITE (ISTDE, *) 'File ', DBGFILE(1:LENDBG), & ' will be created as the RSCF92 DeBuG Printout& - & File;' + & File;' WRITE (ISTDE, *) 'enter another file name if this is not', & - ' acceptable; null otherwise:' - - 123 CONTINUE - READ (*, '(A)') FILNAM - - FILNAM = ADJUSTL(FILNAM) - LENFIL = LEN_TRIM(FILNAM) - IF (LENFIL == 0) THEN - FILNAM = DBGFILE - ELSE IF (LENFIL > LENDBG) THEN + ' acceptable; null otherwise:' + + 123 CONTINUE + READ (*, '(A)') FILNAM + + FILNAM = ADJUSTL(FILNAM) + LENFIL = LEN_TRIM(FILNAM) + IF (LENFIL == 0) THEN + FILNAM = DBGFILE + ELSE IF (LENFIL > LENDBG) THEN WRITE (ISTDE,*) 'File name too long, (> ', LENDBG, '); redo...' - GO TO 123 - ENDIF - - CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'File name not accepted; redo...' - GO TO 123 - ENDIF + GO TO 123 + ENDIF + + CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'File name not accepted; redo...' + GO TO 123 + ENDIF ! ! Set options for general printout ! - WRITE (ISTDE, *) 'Print out the machine constants used?' - LDBPG(1) = GETYN() - WRITE (ISTDE, *) 'Print out the physical constants used?' - LDBPG(2) = GETYN() - WRITE (ISTDE, *) 'Printout from FNDBLK?' - LDBPG(3) = GETYN() - WRITE (ISTDE, *) 'Print out the Hamiltonian matrix?' - LDBPG(4) = GETYN() - WRITE (ISTDE, *) 'Print out the eigenvectors?' - LDBPG(5) = GETYN() -! LDBPG(1:5) = .TRUE. + WRITE (ISTDE, *) 'Print out the machine constants used?' + LDBPG(1) = GETYN() + WRITE (ISTDE, *) 'Print out the physical constants used?' + LDBPG(2) = GETYN() + WRITE (ISTDE, *) 'Printout from FNDBLK?' + LDBPG(3) = GETYN() + WRITE (ISTDE, *) 'Print out the Hamiltonian matrix?' + LDBPG(4) = GETYN() + WRITE (ISTDE, *) 'Print out the eigenvectors?' + LDBPG(5) = GETYN() +! LDBPG(1:5) = .TRUE. ! ! Set options for printout from radial modules ! - WRITE (ISTDE, *) 'Printout from RADGRD?' - LDBPR(1) = GETYN() - WRITE (ISTDE, *) 'Printout from NUCPOT?' - LDBPR(2) = GETYN() - WRITE (ISTDE, *) 'Printout from LODRWF?' - LDBPR(3) = GETYN() - WRITE (ISTDE, *) 'Print out I(ab) integrals?' - LDBPR(4) = GETYN() - WRITE (ISTDE, *) 'Print out Slater integrals?' - LDBPR(10) = GETYN() + WRITE (ISTDE, *) 'Printout from RADGRD?' + LDBPR(1) = GETYN() + WRITE (ISTDE, *) 'Printout from NUCPOT?' + LDBPR(2) = GETYN() + WRITE (ISTDE, *) 'Printout from LODRWF?' + LDBPR(3) = GETYN() + WRITE (ISTDE, *) 'Print out I(ab) integrals?' + LDBPR(4) = GETYN() + WRITE (ISTDE, *) 'Print out Slater integrals?' + LDBPR(10) = GETYN() WRITE (ISTDE, *) 'Make summary printout on progress', & - ' of each iteration in SOLVE?' - LDBPR(22) = GETYN() + ' of each iteration in SOLVE?' + LDBPR(22) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions on', ' each iteration in SOLVE?' - LDBPR(23) = GETYN() + ' of subshell radial functions on', ' each iteration in SOLVE?' + LDBPR(23) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions', ' after each SCF cycle?' - LDBPR(24) = GETYN() + ' of subshell radial functions', ' after each SCF cycle?' + LDBPR(24) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of subshell radial functions on', ' convergence?' - LDBPR(25) = GETYN() - WRITE (ISTDE, *) 'List compositions of exchange', ' potentials?' - LDBPR(27) = GETYN() + ' of subshell radial functions on', ' convergence?' + LDBPR(25) = GETYN() + WRITE (ISTDE, *) 'List compositions of exchange', ' potentials?' + LDBPR(27) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of exchange potentials?' - LDBPR(28) = GETYN() - WRITE (ISTDE, *) 'List compositions of direct', ' potentials?' - LDBPR(29) = GETYN() + ' of exchange potentials?' + LDBPR(28) = GETYN() + WRITE (ISTDE, *) 'List compositions of direct', ' potentials?' + LDBPR(29) = GETYN() WRITE (ISTDE, *) 'Tabulate and make printer plots', & - ' of direct potentials?' - LDBPR(30) = GETYN() -! LDBPR(1:30) = .TRUE. + ' of direct potentials?' + LDBPR(30) = GETYN() +! LDBPR(1:30) = .TRUE. ! ! Set options for printout of angular coefficients ! - WRITE (ISTDE, *) ' Printout from LODCSL?' - LDBPA(1) = GETYN() - WRITE (ISTDE, *) ' Print out T coefficients?' - LDBPA(2) = GETYN() - WRITE (ISTDE, *) ' Print out V coefficients?' - LDBPA(3) = GETYN() -! LDBPA(1:3) = .TRUE. - - RETURN - END SUBROUTINE SETDBG + WRITE (ISTDE, *) ' Printout from LODCSL?' + LDBPA(1) = GETYN() + WRITE (ISTDE, *) ' Print out T coefficients?' + LDBPA(2) = GETYN() + WRITE (ISTDE, *) ' Print out V coefficients?' + LDBPA(3) = GETYN() +! LDBPA(1:3) = .TRUE. + + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rmcdhf90_mpi/setdbg_I.f90 b/src/appl/rmcdhf90_mpi/setdbg_I.f90 index 9ac39f36a..6f8eb89ae 100644 --- a/src/appl/rmcdhf90_mpi/setdbg_I.f90 +++ b/src/appl/rmcdhf90_mpi/setdbg_I.f90 @@ -1,10 +1,10 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setdbg (DBGFILE) - CHARACTER (LEN = *), INTENT(IN) :: DBGFILE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg (DBGFILE) + CHARACTER (LEN = *), INTENT(IN) :: DBGFILE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setdbgmpi.f90 b/src/appl/rmcdhf90_mpi/setdbgmpi.f90 index 8942284b4..85e4c4304 100644 --- a/src/appl/rmcdhf90_mpi/setdbgmpi.f90 +++ b/src/appl/rmcdhf90_mpi/setdbgmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBGmpi(DBGFILE) + SUBROUTINE SETDBGmpi(DBGFILE) ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -11,13 +11,13 @@ SUBROUTINE SETDBGmpi(DBGFILE) ! Modified bu Xinghong He Last update: 06 Jul 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE DEBUG_C + USE DEBUG_C USE MPI_C !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -36,6 +36,6 @@ SUBROUTINE SETDBGmpi(DBGFILE) CALL MPI_Bcast (ldbpa, 5, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) CALL MPI_Bcast (ldbpg, 5, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) CALL MPI_Bcast (ldbpr,30, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - - RETURN + + RETURN END SUBROUTINE SETDBGmpi diff --git a/src/appl/rmcdhf90_mpi/setdbgmpi_I.f90 b/src/appl/rmcdhf90_mpi/setdbgmpi_I.f90 index 9ad103d4c..70ea29a0f 100644 --- a/src/appl/rmcdhf90_mpi/setdbgmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/setdbgmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE setdbgmpi_I + MODULE setdbgmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:22:29 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setdbgmpi (DBGFILE) - CHARACTER (LEN = *), INTENT(IN) :: DBGFILE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbgmpi (DBGFILE) + CHARACTER (LEN = *), INTENT(IN) :: DBGFILE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setham.f90 b/src/appl/rmcdhf90_mpi/setham.f90 index 3edd72d32..e2c5d87a5 100644 --- a/src/appl/rmcdhf90_mpi/setham.f90 +++ b/src/appl/rmcdhf90_mpi/setham.f90 @@ -1,55 +1,55 @@ !*********************************************************************** ! * - SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) + SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man !----------------------------------------------- ! C O M M O N B l o c k s !----------------------------------------------- USE hmat_C - USE MCPA_C + USE MCPA_C USE orb_C USE pos_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE rinti_I - USE fco_I - USE slater_I - USE gco_I + USE iq_I + USE rinti_I + USE fco_I + USE slater_I + USE gco_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JBLOCK - INTEGER , INTENT(IN) :: MYID - INTEGER , INTENT(IN) :: NPROCS + INTEGER :: JBLOCK + INTEGER , INTENT(IN) :: MYID + INTEGER , INTENT(IN) :: NPROCS !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB - CHARACTER*6, PARAMETER :: MYNAME = 'SETHAM' + INTEGER, PARAMETER :: KEY = KEYORB + CHARACTER*6, PARAMETER :: MYNAME = 'SETHAM' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NCFPAT, IA, IR, ITMP, IDIAG, KM, K, K0, IB, NKJIA, NKJIB, KMIN& , KMAX, NDIM, JBLOCKT, NCFT, NCOEFF, IOS, LAB, NCONTR, ICLMNDUM, I, & - LOC, NFILE, ID, IC + LOC, NFILE, ID, IC INTEGER(Long) :: LOD - REAL(DOUBLE) :: DIAA, COEF, F0AA, FKAA, F0AB, GKAB, TEGRAL - LOGICAL :: SET - CHARACTER :: MCPLAB*3 + REAL(DOUBLE) :: DIAA, COEF, F0AA, FKAA, F0AB, GKAB, TEGRAL + LOGICAL :: SET + CHARACTER :: MCPLAB*3 REAL(DOUBLE), DIMENSION(:), POINTER :: coeff INTEGER, DIMENSION(:), POINTER :: indx !----------------------------------------------- @@ -72,282 +72,282 @@ SUBROUTINE SETHAM(JBLOCK, MYID, NPROCS) ! POINTER (PINDX,INDX(1)) ! !----------------------------------------------------------------------- - NCFPAT = NCFPAST(JBLOCK) + NCFPAT = NCFPAST(JBLOCK) !======================================================================= ! Accumulate diagonal terms that do not require MCP coefficients !======================================================================= - + !======================================================================= ! Piece involving I(a,a) integrals !======================================================================= - - DO IA = 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - ITMP = IQ(IA,IR + NCFPAT) - IF (ITMP <= 0) CYCLE + + DO IA = 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + ITMP = IQ(IA,IR + NCFPAT) + IF (ITMP <= 0) CYCLE !*** Occupation number not zero ... - IF (.NOT.SET) THEN - DIAA = RINTI(IA,IA,0) - SET = .TRUE. - ENDIF + IF (.NOT.SET) THEN + DIAA = RINTI(IA,IA,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) ! lower-triangle-by-rows mode - EMT(IDIAG) = EMT(IDIAG) + ITMP*DIAA - END DO - END DO - + IDIAG = IENDC(IR) ! lower-triangle-by-rows mode + EMT(IDIAG) = EMT(IDIAG) + ITMP*DIAA + END DO + END DO + !======================================================================= ! 0 ! Piece involving F (a,a) integrals !======================================================================= - - DO IA = 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(0,IR + NCFPAT,IA,IA) - IF (COEF == 0.D0) CYCLE + + DO IA = 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(0,IR + NCFPAT,IA,IA) + IF (COEF == 0.D0) CYCLE !*** Angular coefficient not zero ... - IF (.NOT.SET) THEN - F0AA = SLATER(IA,IA,IA,IA,0) - SET = .TRUE. - ENDIF + IF (.NOT.SET) THEN + F0AA = SLATER(IA,IA,IA,IA,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*F0AA - END DO - END DO - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*F0AA + END DO + END DO + !======================================================================= ! k ! Piece involving F (a,a) integrals !======================================================================= - - KM = 0 - K = 0 - 6 CONTINUE - K = K + 2 - DO IA = 1, NW - K0 = NKJ(IA) - 1 - KM = MAX0(K0,KM) - IF (K > K0) CYCLE - SET = .FALSE. - - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(K,IR + NCFPAT,IA,IA) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - FKAA = SLATER(IA,IA,IA,IA,K) - SET = .TRUE. - ENDIF + + KM = 0 + K = 0 + 6 CONTINUE + K = K + 2 + DO IA = 1, NW + K0 = NKJ(IA) - 1 + KM = MAX0(K0,KM) + IF (K > K0) CYCLE + SET = .FALSE. + + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(K,IR + NCFPAT,IA,IA) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + FKAA = SLATER(IA,IA,IA,IA,K) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*FKAA - END DO - END DO - IF (K < KM) GO TO 6 - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*FKAA + END DO + END DO + IF (K < KM) GO TO 6 + !======================================================================= ! 0 ! Piece involving F (a,b) integrals !======================================================================= - - DO IA = 1, NW - 1 - DO IB = IA + 1, NW - SET = .FALSE. - DO IR = MYID + 1, NCF, NPROCS - COEF = FCO(0,IR + NCFPAT,IA,IB) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - F0AB = SLATER(IA,IB,IA,IB,0) - SET = .TRUE. - ENDIF + + DO IA = 1, NW - 1 + DO IB = IA + 1, NW + SET = .FALSE. + DO IR = MYID + 1, NCF, NPROCS + COEF = FCO(0,IR + NCFPAT,IA,IB) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + F0AB = SLATER(IA,IB,IA,IB,0) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*F0AB - END DO - END DO - END DO - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*F0AB + END DO + END DO + END DO + !======================================================================= ! k ! Piece involving G (a,b) integrals !======================================================================= - - KM = 0 - K = -1 - 12 CONTINUE - K = K + 1 - DO IA = 1, NW - 1 - NKJIA = NKJ(IA) - DO IB = IA + 1, NW - NKJIB = NKJ(IB) - SET = .FALSE. - IF (NAK(IA)*NAK(IB) > 0) THEN - KMIN = ABS((NKJIA - NKJIB)/2) - ELSE - KMIN = ABS((NKJIA - NKJIB)/2) + 1 - ENDIF - IF (MOD(K - KMIN,2) /= 0) CYCLE - - KMAX = (NKJIA + NKJIB)/2 - KM = MAX0(KMAX,KM) - IF (KKMAX) CYCLE - - DO IR = MYID + 1, NCF, NPROCS - COEF = GCO(K,IR + NCFPAT,IA,IB) - IF (COEF == 0.D0) CYCLE - IF (.NOT.SET) THEN - GKAB = SLATER(IA,IB,IB,IA,K) - SET = .TRUE. - ENDIF + + KM = 0 + K = -1 + 12 CONTINUE + K = K + 1 + DO IA = 1, NW - 1 + NKJIA = NKJ(IA) + DO IB = IA + 1, NW + NKJIB = NKJ(IB) + SET = .FALSE. + IF (NAK(IA)*NAK(IB) > 0) THEN + KMIN = ABS((NKJIA - NKJIB)/2) + ELSE + KMIN = ABS((NKJIA - NKJIB)/2) + 1 + ENDIF + IF (MOD(K - KMIN,2) /= 0) CYCLE + + KMAX = (NKJIA + NKJIB)/2 + KM = MAX0(KMAX,KM) + IF (KKMAX) CYCLE + + DO IR = MYID + 1, NCF, NPROCS + COEF = GCO(K,IR + NCFPAT,IA,IB) + IF (COEF == 0.D0) CYCLE + IF (.NOT.SET) THEN + GKAB = SLATER(IA,IB,IB,IA,K) + SET = .TRUE. + ENDIF ! IDIAG = IENDC(IR-1)+1 - IDIAG = IENDC(IR) - EMT(IDIAG) = EMT(IDIAG) + COEF*GKAB - END DO - END DO - END DO - IF (K < KM) GO TO 12 - + IDIAG = IENDC(IR) + EMT(IDIAG) = EMT(IDIAG) + COEF*GKAB + END DO + END DO + END DO + IF (K < KM) GO TO 12 + !======================================================================= ! Local storage for reading mcpXXX files !======================================================================= - - NDIM = 1 - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM' ) - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - + + NDIM = 1 + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM' ) + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + !======================================================================= ! Accumulate one-electron terms that require MCP coefficients !======================================================================= - - READ (31) MCPLAB, JBLOCKT, NCFT, NCOEFF - - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ': blk1=', JBLOCKT, ' blk2=', JBLOCK - STOP - ENDIF - IF (NCFT /= NCF) THEN - WRITE (ISTDE, *) MYNAME, ': ncf1 = ', NCFT, ' ncf2 = ', NCF - STOP - ENDIF - + + READ (31) MCPLAB, JBLOCKT, NCFT, NCOEFF + + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ': blk1=', JBLOCKT, ' blk2=', JBLOCK + STOP + ENDIF + IF (NCFT /= NCF) THEN + WRITE (ISTDE, *) MYNAME, ': ncf1 = ', NCFT, ' ncf2 = ', NCF + STOP + ENDIF + !======================================================================= ! Loop over non-zero labels which have non-zero elements !======================================================================= - - READ (31, IOSTAT=IOS) LAB, NCONTR - IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR' - DO WHILE(LAB/=0 .OR. NCONTR/=0) - + + READ (31, IOSTAT=IOS) LAB, NCONTR + IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR' + DO WHILE(LAB/=0 .OR. NCONTR/=0) + !*** decode the label of I(ab) - IA = MOD(LAB,KEY) - IB = LAB/KEY - + IA = MOD(LAB,KEY) + IB = LAB/KEY + !*** Compute radial integral I(ab) - TEGRAL = RINTI(IA,IB,0) - + TEGRAL = RINTI(IA,IB,0) + ! Read column index, sparse matrix index, and coefficient ! for all contributions from this integral. - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - ENDIF - READ (31) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + ENDIF + READ (31) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) + !*** Store all the contributions from this integral - DO I = 1, NCONTR - LOC = INDX(I) + DO I = 1, NCONTR + LOC = INDX(I) LOD = LOC - IF (LOD > (NELMNT)) THEN - WRITE (6, *) ' Error in computing 1-e contribution' + IF (LOD > (NELMNT)) THEN + WRITE (6, *) ' Error in computing 1-e contribution' WRITE (6, *) ' LOC = ', LOC, ' NELMNT = ', (NELMNT) - STOP - ENDIF - EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) - END DO - - READ (31, IOSTAT=IOS) LAB, NCONTR - IF (IOS == 0) CYCLE - STOP 'IOS .NE. 0 when reading LAB, NCONTR' - END DO - + STOP + ENDIF + EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) + END DO + + READ (31, IOSTAT=IOS) LAB, NCONTR + IF (IOS == 0) CYCLE + STOP 'IOS .NE. 0 when reading LAB, NCONTR' + END DO + !======================================================================= ! Accumulate two-electron terms that require MCP coefficients !======================================================================= - - DO NFILE = 32, 32 + KMAXF - K = NFILE - 32 - - READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF - - IF (JBLOCKT /= JBLOCK) THEN - WRITE (ISTDE, *) MYNAME, ': blk3=', JBLOCKT, ' blk4=', JBLOCK - STOP - ENDIF - IF (NCFT /= NCF) THEN - WRITE (ISTDE, *) MYNAME, ': ncf3 = ', NCFT, ' ncf4 = ', NCF - STOP - ENDIF - + + DO NFILE = 32, 32 + KMAXF + K = NFILE - 32 + + READ (NFILE) MCPLAB, JBLOCKT, NCFT, NCOEFF + + IF (JBLOCKT /= JBLOCK) THEN + WRITE (ISTDE, *) MYNAME, ': blk3=', JBLOCKT, ' blk4=', JBLOCK + STOP + ENDIF + IF (NCFT /= NCF) THEN + WRITE (ISTDE, *) MYNAME, ': ncf3 = ', NCFT, ' ncf4 = ', NCF + STOP + ENDIF + !======================================================================= ! Loop over non-zero labels which have non-zero elements !======================================================================= - - READ (NFILE, IOSTAT=IOS) LAB, NCONTR - IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' - DO WHILE(LAB/=0 .OR. NCONTR/=0) - + + READ (NFILE, IOSTAT=IOS) LAB, NCONTR + IF (IOS /= 0) STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' + DO WHILE(LAB/=0 .OR. NCONTR/=0) + ! k !*** decode the label of R (abcd) - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY - + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY + !*** Compute radial integral - TEGRAL = SLATER(IA,IB,IC,ID,K) - + TEGRAL = SLATER(IA,IB,IC,ID,K) + ! Read column index, sparse matrix index, and coefficient ! for all contributions from this integral. - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') - CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') - ENDIF - READ (NFILE) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) - + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', 'SETHAM') + CALL ALLOC (INDX, NDIM, 'INDX', 'SETHAM') + ENDIF + READ (NFILE) (ICLMNDUM,INDX(I),COEFF(I),I=1,NCONTR) + !*** Store all the contributions from this integral - DO I = 1, NCONTR - LOC = INDX(I) + DO I = 1, NCONTR + LOC = INDX(I) LOD = LOC - IF (LOD > NELMNT) THEN - WRITE (6, *) ' Error in computing 2-e contribution' + IF (LOD > NELMNT) THEN + WRITE (6, *) ' Error in computing 2-e contribution' WRITE (6, *) ' LOC = ', LOC, ' NELMNT = ', NELMNT - STOP - ENDIF - EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) - END DO - - READ (NFILE, IOSTAT=IOS) LAB, NCONTR - IF (IOS == 0) CYCLE - STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' - END DO - END DO - + STOP + ENDIF + EMT(LOC) = EMT(LOC) + TEGRAL*COEFF(I) + END DO + + READ (NFILE, IOSTAT=IOS) LAB, NCONTR + IF (IOS == 0) CYCLE + STOP 'IOS .NE. 0 when reading LAB, NCONTR 2' + END DO + END DO + !======================================================================= ! Deallocate local storage !======================================================================= - - CALL DALLOC (COEFF, 'COEFF', 'SETHAM') - CALL DALLOC (INDX, 'INDX', 'SETHAM') - - RETURN - END SUBROUTINE SETHAM + + CALL DALLOC (COEFF, 'COEFF', 'SETHAM') + CALL DALLOC (INDX, 'INDX', 'SETHAM') + + RETURN + END SUBROUTINE SETHAM diff --git a/src/appl/rmcdhf90_mpi/setham_I.f90 b/src/appl/rmcdhf90_mpi/setham_I.f90 index 8263cf9e3..a73508c54 100644 --- a/src/appl/rmcdhf90_mpi/setham_I.f90 +++ b/src/appl/rmcdhf90_mpi/setham_I.f90 @@ -1,12 +1,12 @@ - MODULE setham_I + MODULE setham_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:23:52 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setham (JBLOCK, MYID, NPROCS) - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: MYID - INTEGER, INTENT(IN) :: NPROCS - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setham (JBLOCK, MYID, NPROCS) + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: MYID + INTEGER, INTENT(IN) :: NPROCS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setlagmpi.f90 b/src/appl/rmcdhf90_mpi/setlagmpi.f90 index ee9627cb6..e7ebaf54c 100644 --- a/src/appl/rmcdhf90_mpi/setlagmpi.f90 +++ b/src/appl/rmcdhf90_mpi/setlagmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETLAGmpi(EOL) + SUBROUTINE SETLAGmpi(EOL) ! * ! Sets up the data structure pertaining to the Lagrange multipli- * ! ers on the first entry; on subsequent calls it determines new * @@ -13,16 +13,16 @@ SUBROUTINE SETLAGmpi(EOL) ! MPI version by Xinghong He Last update: 03 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNP USE memory_man - USE ORBA_C + USE ORBA_C USE core_C USE def_C USE fixd_C @@ -37,38 +37,38 @@ SUBROUTINE SETLAGmpi(EOL) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcof_I - USE ypot_I - USE xpot_I - USE dacon_I - USE quad_I - USE rinti_I + USE setcof_I + USE ypot_I + USE xpot_I + USE dacon_I + USE quad_I + USE rinti_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL :: EOL + LOGICAL :: EOL !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: P001 = 1.0D-01 - INTEGER, PARAMETER :: KEY = KEYORB + REAL(DOUBLE), PARAMETER :: P001 = 1.0D-01 + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, & - JLAST, MLAST, M, J, I - REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM + JLAST, MLAST, M, J, I + REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM REAL(DOUBLE) :: EPS,UCFJ,UCFM,RESULT,RIJM,QDIF,OBQDIF,OBQSUM,TMP - LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ + LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ !----------------------------------------------- ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! !----------------------------------------------------------------------- - - IF (FIRST) THEN - + + IF (FIRST) THEN + !======================================================================= ! Determine the total number of Lagrange multipliers and store ! their indeces in IECC(1:NEC). Memories are allocated for IECC @@ -81,48 +81,48 @@ SUBROUTINE SETLAGmpi(EOL) ! ! This part is not distributed. !======================================================================= - - EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied - DO ITWICE = 1, 2 - NEC = 0 -! IF (ITWICE /= 2) THEN -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS + + EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied + DO ITWICE = 1, 2 + NEC = 0 +! IF (ITWICE /= 2) THEN +! DO LIRAW = 1, NW - 1 +! LI = IORDER(LIRAW) +! LIP1 = MAX(NCORE,LIRAW) + 1 +! NAKLI = NAK(LI) +! FIXLI = LFIX(LI) +! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS +! DO LJRAW = LIP1, NW +! LJ = IORDER(LJRAW) +! FIXLJ = LFIX(LJ) +! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS ! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! CYCLE +! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE +! NEC = NEC + 1 +! CYCLE ! !*** Encode index at 2nd round *** -! END DO -! END DO -! ELSE -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS +! END DO +! END DO +! ELSE +! DO LIRAW = 1, NW - 1 +! LI = IORDER(LIRAW) +! LIP1 = MAX(NCORE,LIRAW) + 1 +! NAKLI = NAK(LI) +! FIXLI = LFIX(LI) +! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS ! !*** Encode index at 2nd round *** -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS +! DO LJRAW = LIP1, NW +! LJ = IORDER(LJRAW) +! FIXLJ = LFIX(LJ) +! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS ! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 +! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE +! NEC = NEC + 1 ! !*** Encode index at 2nd round *** -! IECC(NEC) = LI + KEY*LJ -! END DO -! END DO -! ENDIF +! IECC(NEC) = LI + KEY*LJ +! END DO +! END DO +! ENDIF DO LIraw = 1, NW - 1 LI = iorder(LIraw) LIP1 = MAX (NCORE, LIraw) + 1 @@ -144,86 +144,86 @@ SUBROUTINE SETLAGmpi(EOL) ENDDO - IF (ITWICE==1 .AND. NEC>0) THEN - CALL ALLOC (ECV, NEC, 'ECV', 'SETLAGmpi') - CALL ALLOC (IECC, NEC, 'IECC', 'SETLAGmpi') - ELSE - EXIT - ENDIF - END DO !itwice - + IF (ITWICE==1 .AND. NEC>0) THEN + CALL ALLOC (ECV, NEC, 'ECV', 'SETLAGmpi') + CALL ALLOC (IECC, NEC, 'IECC', 'SETLAGmpi') + ELSE + EXIT + ENDIF + END DO !itwice + !======================================================================= ! Print information about Lagrange multipliers !======================================================================= - - IF (MYID == 0) THEN - IF (NEC == 0) THEN - WRITE (*, 302) - ELSE - WRITE (*, 304) - DO LI = 1, NEC + + IF (MYID == 0) THEN + IF (NEC == 0) THEN + WRITE (*, 302) + ELSE + WRITE (*, 304) + DO LI = 1, NEC !*** Decode index *** - IECCLI = IECC(LI) - L1 = IECCLI/KEY - L2 = IECCLI - KEY*L1 - WRITE (*, 305) NP(L2), NH(L2), NP(L1), NH(L1) - END DO - ENDIF - ENDIF - FIRST = .FALSE. - ENDIF - + IECCLI = IECC(LI) + L1 = IECCLI/KEY + L2 = IECCLI - KEY*L1 + WRITE (*, 305) NP(L2), NH(L2), NP(L1), NH(L1) + END DO + ENDIF + ENDIF + FIRST = .FALSE. + ENDIF + !FF+GG 12/07/05 ! Lagrange multipliers need to be computed also on the first call ! RETURN - - IF (NEC == 0) RETURN - IF (MYID == 0) WRITE (*, 306) - JLAST = 0 - MLAST = 0 - - DO LI = 1, NEC + + IF (NEC == 0) RETURN + IF (MYID == 0) WRITE (*, 306) + JLAST = 0 + MLAST = 0 + + DO LI = 1, NEC !*** Decode index *** - IECCLI = IECC(LI) - M = IECCLI/KEY - J = IECCLI - KEY*M + IECCLI = IECC(LI) + M = IECCLI/KEY + J = IECCLI - KEY*M ! - IF (J /= JLAST) THEN - UCFJ = UCF(J) - CALL SETCOF (EOL, J) - CALL YPOT (J) - CALL XPOT (J) - CALL DACON - YPJ(:N) = YP(:N) - XPJ(:N) = XP(:N) - XQJ(:N) = XQ(:N) - JLAST = J - ENDIF + IF (J /= JLAST) THEN + UCFJ = UCF(J) + CALL SETCOF (EOL, J) + CALL YPOT (J) + CALL XPOT (J) + CALL DACON + YPJ(:N) = YP(:N) + XPJ(:N) = XP(:N) + XQJ(:N) = XQ(:N) + JLAST = J + ENDIF ! - IF (M /= MLAST) THEN - UCFM = UCF(M) - CALL SETCOF (EOL, M) - CALL YPOT (M) - CALL XPOT (M) - CALL DACON - YPM(:N) = YP(:N) - XPM(:N) = XP(:N) - XQM(:N) = XQ(:N) - MLAST = M - ENDIF + IF (M /= MLAST) THEN + UCFM = UCF(M) + CALL SETCOF (EOL, M) + CALL YPOT (M) + CALL XPOT (M) + CALL DACON + YPM(:N) = YP(:N) + XPM(:N) = XP(:N) + XQM(:N) = XQ(:N) + MLAST = M + ENDIF ! - MTP = MAX(MF(J),MF(M)) + MTP = MAX(MF(J),MF(M)) ! - IF (LFIX(M)) THEN - TA(1) = 0.D0 - DO I = 2, MTP + IF (LFIX(M)) THEN + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I& - ,J)+QF(I,M)*QF(I,J))*YPJ(I)) - END DO - - CALL QUAD (RESULT) - RIJM = RINTI(M,J,1) - ECV(LI) = (RESULT - RIJM / nprocs)*UCFJ + ,J)+QF(I,M)*QF(I,J))*YPJ(I)) + END DO + + CALL QUAD (RESULT) + RIJM = RINTI(M,J,1) + ECV(LI) = (RESULT - RIJM / nprocs)*UCFJ ! start dbg ! WRITE (81,*)'1, RESULT, RIJM, UCFJ, ECV, TA' ! dbg ! WRITE (81,*)RESULT, RIJM, UCFJ, ECV ! dbg @@ -231,15 +231,15 @@ SUBROUTINE SETLAGmpi(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! dbg ! ENDDO ! dbg ! end dbg - - ELSE IF (LFIX(J)) THEN - TA(1) = 0.D0 - DO I = 2, MTP + + ELSE IF (LFIX(J)) THEN + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I& - ,M)+QF(I,J)*QF(I,M))*YPM(I)) + ,M)+QF(I,J)*QF(I,M))*YPM(I)) !GG write(222,*)"XQM(I)",XQM(I) - END DO - + END DO + !start dbg ! DO i = 1, MTP ! WRITE (81,*) i, TA(i) @@ -249,29 +249,29 @@ SUBROUTINE SETLAGmpi(EOL) ! write(86,*)i,xpm(i),xqm(i) ! ENDDO ! end dbg - CALL QUAD (RESULT) - - RIJM = RINTI(J,M,1) !/ nprocs - ECV(LI) = (RESULT - RIJM / nprocs)*UCFM + CALL QUAD (RESULT) + + RIJM = RINTI(J,M,1) !/ nprocs + ECV(LI) = (RESULT - RIJM / nprocs)*UCFM !start dbg ! WRITE (81,*)'2, RESULT, RIJM, UCFM, ECV, TA' ! WRITE (81,*)RESULT, RIJM, UCFJ, ECV, r(i), rp(i) !end dbg - - - ELSE - QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) - IF (QDIF > P001) THEN - OBQDIF = 1.D0/UCFJ - 1.D0/UCFM - TA(1) = 0.D0 - DO I = 2, MTP + + + ELSE + QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) + IF (QDIF > P001) THEN + OBQDIF = 1.D0/UCFJ - 1.D0/UCFM + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I& )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) - END DO - - CALL QUAD (RESULT) - ECV(LI) = RESULT/OBQDIF + M)*QF(I,J))) + END DO + + CALL QUAD (RESULT) + ECV(LI) = RESULT/OBQDIF !start dbg ! WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA' ! WRITE (81,*)RESULT, OBQDIF, ECV @@ -279,20 +279,20 @@ SUBROUTINE SETLAGmpi(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! ENDDO !end dbg - - - ELSE - OBQSUM = 1.D0/UCFJ + 1.D0/UCFM - TA(1) = 0.D0 - DO I = 2, MTP + + + ELSE + OBQSUM = 1.D0/UCFJ + 1.D0/UCFM + TA(1) = 0.D0 + DO I = 2, MTP TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I& )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) - END DO - - CALL QUAD (RESULT) - RIJM = RINTI(M,J,1) !/ nprocs - ECV(LI) = (RESULT - 2.D0*RIJM / nprocs)/OBQSUM + M)*QF(I,J))) + END DO + + CALL QUAD (RESULT) + RIJM = RINTI(M,J,1) !/ nprocs + ECV(LI) = (RESULT - 2.D0*RIJM / nprocs)/OBQSUM !start dbg ! WRITE (81,*)'4, RESULT, RIUJM, OBQSUM, ECV, TA' ! WRITE (81,*)RESULT, RIUJM, OBQSUM, ECV @@ -300,9 +300,9 @@ SUBROUTINE SETLAGmpi(EOL) ! WRITE (81,*) i, TA(i), r(i), rp(i) ! ENDDO !end dbg - - ENDIF - ENDIF + + ENDIF + ENDIF !======================================================================= ! Collect contributions from all nodes. ! Another alternative is to modify mcpmpi to let every node @@ -313,20 +313,20 @@ SUBROUTINE SETLAGmpi(EOL) CALL MPI_Allreduce (ECV(LI),tmp,1,MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) ECV(LI) = tmp - + IF(MYID == 0)WRITE (*, 307) NP(J), NH(J), NP(M), NH(M), ECV(LI) - - END DO - + + END DO + !db close(81) !db close(82) - - - 302 FORMAT(/,'Lagrange multipliers are not required') - 304 FORMAT(/,'Include Lagrange multipliers between:'/) - 305 FORMAT(13X,2(2X,1I2,1A2)) - 306 FORMAT(/,'Lagrange multipliers:'/) - 307 FORMAT(13X,2(2X,1I2,1A2),2X,1P,D16.9) - - RETURN + + + 302 FORMAT(/,'Lagrange multipliers are not required') + 304 FORMAT(/,'Include Lagrange multipliers between:'/) + 305 FORMAT(13X,2(2X,1I2,1A2)) + 306 FORMAT(/,'Lagrange multipliers:'/) + 307 FORMAT(13X,2(2X,1I2,1A2),2X,1P,D16.9) + + RETURN END SUBROUTINE SETLAGmpi diff --git a/src/appl/rmcdhf90_mpi/setlagmpi_I.f90 b/src/appl/rmcdhf90_mpi/setlagmpi_I.f90 index ca877da81..611a6a617 100644 --- a/src/appl/rmcdhf90_mpi/setlagmpi_I.f90 +++ b/src/appl/rmcdhf90_mpi/setlagmpi_I.f90 @@ -1,11 +1,11 @@ - MODULE setlagmpi_I + MODULE setlagmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:25:08 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setlagmpi (EOL) - LOGICAL :: EOL + SUBROUTINE setlagmpi (EOL) + LOGICAL :: EOL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setmcp.f90 b/src/appl/rmcdhf90_mpi/setmcp.f90 index 507e4146b..cf4ee20ed 100644 --- a/src/appl/rmcdhf90_mpi/setmcp.f90 +++ b/src/appl/rmcdhf90_mpi/setmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** - - SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) + + SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) ! ! Open, read, check the header of all .mcp files. Info for each ! block is not accessed here. @@ -29,17 +29,17 @@ SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) ! Modified by Xinghong He Last revision: 06 Aug 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE DEF_C USE FOPARM_C - USE MCPA_C + USE MCPA_C USE MCPB_C USE mpi_C USE orb_C @@ -48,102 +48,102 @@ SUBROUTINE SETMCP(NCORE, NBLKIN, IDBLK, FILEHEAD) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - INTEGER , INTENT(IN) :: NBLKIN - CHARACTER , INTENT(IN) :: FILEHEAD*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: NCORE + INTEGER , INTENT(IN) :: NBLKIN + CHARACTER , INTENT(IN) :: FILEHEAD*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENFH, IERROR, IOS, I, K, LCK, MYIDD, NPROCSS - LOGICAL :: FOUND, FOUND1 - CHARACTER :: CK*2, MCPLAB*3 + INTEGER :: LENFH, IERROR, IOS, I, K, LCK, MYIDD, NPROCSS + LOGICAL :: FOUND, FOUND1 + CHARACTER :: CK*2, MCPLAB*3 CHARACTER(LEN=120) :: FILNAM !----------------------------------------------- ! - LENFH = LEN_TRIM(FILEHEAD) - - FILNAM = FILEHEAD(1:LENFH)//'.30' + LENFH = LEN_TRIM(FILEHEAD) + + FILNAM = FILEHEAD(1:LENFH)//'.30' OPEN(30, FILE=FILNAM, FORM='UNFORMATTED', STATUS='OLD', IOSTAT=IERROR, & - POSITION='asis') - + POSITION='asis') + ! Parameter ierror carries through mcp.30,... mcp.kmax - - READ (30, IOSTAT=IOS) NCORE, NBLOCK, KMAXF - IERROR = IERROR + ABS(IOS) - IF (NBLOCK>NBLKIN .OR. NBLOCK<1) THEN - WRITE (ISTDE, *) 'setmcp: nblock = ', NBLOCK - STOP - ENDIF - + + READ (30, IOSTAT=IOS) NCORE, NBLOCK, KMAXF + IERROR = IERROR + ABS(IOS) + IF (NBLOCK>NBLKIN .OR. NBLOCK<1) THEN + WRITE (ISTDE, *) 'setmcp: nblock = ', NBLOCK + STOP + ENDIF + !cjb allocate ncfblk(0:*) !cjb CALL ALLOC (NCFBLK, NBLOCK + 1, 'NCFBLK', 'SETMCP') CALL ALLOC (NCFBLK, 0, NBLOCK , 'NCFBLK', 'SETMCP') !cjb - NCFBLK(0) = 0 - - READ (30, IOSTAT=IOS) (NCFBLK(I),I=1,NBLOCK) - IERROR = IERROR + ABS(IOS) - READ (30, IOSTAT=IOS) (IDBLK(I),I=1,NBLOCK) - IERROR = IERROR + ABS(IOS) - + NCFBLK(0) = 0 + + READ (30, IOSTAT=IOS) (NCFBLK(I),I=1,NBLOCK) + IERROR = IERROR + ABS(IOS) + READ (30, IOSTAT=IOS) (IDBLK(I),I=1,NBLOCK) + IERROR = IERROR + ABS(IOS) + ! Look for other mcp files - - FOUND = .TRUE. - DO K = 31, 32 + KMAXF - CALL CONVRT (K, CK, LCK) - FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) - INQUIRE(FILE=FILNAM, EXIST=FOUND1) - FOUND = FOUND .AND. FOUND1 - END DO - - IF (.NOT.FOUND) THEN - WRITE (ISTDE, *) 'The mcp files do not exist' - STOP - ENDIF - + + FOUND = .TRUE. + DO K = 31, 32 + KMAXF + CALL CONVRT (K, CK, LCK) + FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) + INQUIRE(FILE=FILNAM, EXIST=FOUND1) + FOUND = FOUND .AND. FOUND1 + END DO + + IF (.NOT.FOUND) THEN + WRITE (ISTDE, *) 'The mcp files do not exist' + STOP + ENDIF + ! Open the files; check file headers - - DO K = 30, 32 + KMAXF - - IF (K /= 30) THEN - CALL CONVRT (K, CK, LCK) - FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) - CALL OPENFL (K, FILNAM, 'UNFORMATTED', 'OLD', IERROR) - ENDIF - - READ (K, IOSTAT=IOS) MCPLAB, NBLOCK, MYIDD, NPROCSS - - IERROR = IERROR + ABS(IOS) - IF (MYID/=MYIDD .OR. NPROCS/=NPROCSS) THEN + + DO K = 30, 32 + KMAXF + + IF (K /= 30) THEN + CALL CONVRT (K, CK, LCK) + FILNAM = FILEHEAD(1:LENFH)//'.'//CK(1:2) + CALL OPENFL (K, FILNAM, 'UNFORMATTED', 'OLD', IERROR) + ENDIF + + READ (K, IOSTAT=IOS) MCPLAB, NBLOCK, MYIDD, NPROCSS + + IERROR = IERROR + ABS(IOS) + IF (MYID/=MYIDD .OR. NPROCS/=NPROCSS) THEN WRITE (ISTDE, *) 'mcp files were generated under different', & - ' processor configuration.' - STOP - ENDIF - - IF (MCPLAB /= 'MCP') THEN - WRITE (ISTDE, *) 'Not a sorted GRASP92 MCP File;' - IERROR = IERROR + 1 - ENDIF - - READ (K, IOSTAT=IOS) NELEC, NCF, NW - IERROR = IERROR + ABS(IOS) - READ (K, IOSTAT=IOS) DIAG, ICCUT, LFORDR - IERROR = IERROR + ABS(IOS) - - IF (IERROR == 0) CYCLE - WRITE (ISTDE, *) 'setmcp: Error accumulated , stopping...' - DO I = 30, K - CLOSE(I) - END DO - STOP - END DO - - RETURN - END SUBROUTINE SETMCP + ' processor configuration.' + STOP + ENDIF + + IF (MCPLAB /= 'MCP') THEN + WRITE (ISTDE, *) 'Not a sorted GRASP92 MCP File;' + IERROR = IERROR + 1 + ENDIF + + READ (K, IOSTAT=IOS) NELEC, NCF, NW + IERROR = IERROR + ABS(IOS) + READ (K, IOSTAT=IOS) DIAG, ICCUT, LFORDR + IERROR = IERROR + ABS(IOS) + + IF (IERROR == 0) CYCLE + WRITE (ISTDE, *) 'setmcp: Error accumulated , stopping...' + DO I = 30, K + CLOSE(I) + END DO + STOP + END DO + + RETURN + END SUBROUTINE SETMCP diff --git a/src/appl/rmcdhf90_mpi/setmcp_I.f90 b/src/appl/rmcdhf90_mpi/setmcp_I.f90 index 9843ed938..4dd886f8f 100644 --- a/src/appl/rmcdhf90_mpi/setmcp_I.f90 +++ b/src/appl/rmcdhf90_mpi/setmcp_I.f90 @@ -1,14 +1,14 @@ - MODULE setmcp_I + MODULE setmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:27:31 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmcp (NCORE, NBLKIN, IDBLK, FILEHEAD) - INTEGER :: NCORE - INTEGER, INTENT(IN) :: NBLKIN - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK - CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD + SUBROUTINE setmcp (NCORE, NBLKIN, IDBLK, FILEHEAD) + INTEGER :: NCORE + INTEGER, INTENT(IN) :: NBLKIN + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + CHARACTER (LEN = *), INTENT(IN) :: FILEHEAD !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setmix.f90 b/src/appl/rmcdhf90_mpi/setmix.f90 index f96d2cce4..60e9f45d8 100644 --- a/src/appl/rmcdhf90_mpi/setmix.f90 +++ b/src/appl/rmcdhf90_mpi/setmix.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE SETMIX(NAME) + SUBROUTINE SETMIX(NAME) ! ! Opens the .mix file on stream 25; writes a header to this file. * ! * @@ -9,13 +9,13 @@ SUBROUTINE SETMIX(NAME) ! Modified by Xinghong He Last revision: 13 Jul 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE foparm_C USE mcpa_C @@ -26,16 +26,16 @@ SUBROUTINE SETMIX(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME*(*) + CHARACTER :: NAME*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR + INTEGER :: IERR !----------------------------------------------- ! POINTER (PCCMIN,ICCMIN(1)) ! POINTER (PNTRIQ,RIQDUM) @@ -45,19 +45,19 @@ SUBROUTINE SETMIX(NAME) ! POINTER (pncfblk,ncfblk(0:*)) ! !----------------------------------------------------------------------- - CALL OPENFL (25, NAME, 'UNFORMATTED', 'NEW', IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) - STOP - ENDIF + CALL OPENFL (25, NAME, 'UNFORMATTED', 'NEW', IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) + STOP + ENDIF ! ! Write the file header ! - WRITE (25) 'G92MIX' - WRITE (25) NELEC, NCF, NW, 0, 0, NBLOCK + WRITE (25) 'G92MIX' + WRITE (25) NELEC, NCF, NW, 0, 0, NBLOCK ! ...The above record will be overidden in matrix.f ! with the final form of ! WRITE (25) NELEC, NCF, NW, nvectot, nvecsiz, nblock - - RETURN - END SUBROUTINE SETMIX + + RETURN + END SUBROUTINE SETMIX diff --git a/src/appl/rmcdhf90_mpi/setmix_I.f90 b/src/appl/rmcdhf90_mpi/setmix_I.f90 index 2d58b604e..5309bcd0a 100644 --- a/src/appl/rmcdhf90_mpi/setmix_I.f90 +++ b/src/appl/rmcdhf90_mpi/setmix_I.f90 @@ -1,10 +1,10 @@ - MODULE setmix_I + MODULE setmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmix (NAME) - CHARACTER (LEN = *), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmix (NAME) + CHARACTER (LEN = *), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setsum.f90 b/src/appl/rmcdhf90_mpi/setsum.f90 index 301553130..843b70d76 100644 --- a/src/appl/rmcdhf90_mpi/setsum.f90 +++ b/src/appl/rmcdhf90_mpi/setsum.f90 @@ -1,8 +1,8 @@ !*********************************************************************** - SUBROUTINE SETSUM(FILNAM) + SUBROUTINE SETSUM(FILNAM) !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M O D U L E S @@ -11,28 +11,28 @@ SUBROUTINE SETSUM(FILNAM) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: FILNAM*(*) + CHARACTER :: FILNAM*(*) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' - CHARACTER*3, PARAMETER :: STATUS = 'NEW' + CHARACTER*9, PARAMETER :: FORM = 'FORMATTED' + CHARACTER*3, PARAMETER :: STATUS = 'NEW' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR -!----------------------------------------------- - - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error when opening ', FILNAM - STOP - ENDIF - - RETURN - END SUBROUTINE SETSUM + INTEGER :: IERR +!----------------------------------------------- + + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error when opening ', FILNAM + STOP + ENDIF + + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rmcdhf90_mpi/setsum_I.f90 b/src/appl/rmcdhf90_mpi/setsum_I.f90 index cef3ee209..601fc2019 100644 --- a/src/appl/rmcdhf90_mpi/setsum_I.f90 +++ b/src/appl/rmcdhf90_mpi/setsum_I.f90 @@ -1,10 +1,10 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setsum (FILNAM) - CHARACTER (LEN = *), INTENT(IN) :: FILNAM - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (FILNAM) + CHARACTER (LEN = *), INTENT(IN) :: FILNAM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setxuv.f90 b/src/appl/rmcdhf90_mpi/setxuv.f90 index 329e97303..5de54af9a 100644 --- a/src/appl/rmcdhf90_mpi/setxuv.f90 +++ b/src/appl/rmcdhf90_mpi/setxuv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETXUV(J) + SUBROUTINE SETXUV(J) ! * ! This SUBROUTINE sets up the arrays XU and XV, for use by the * ! subprograms IN and OUT. * @@ -8,13 +8,13 @@ SUBROUTINE SETXUV(J) ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE int_C @@ -24,31 +24,31 @@ SUBROUTINE SETXUV(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NM1, I - REAL(DOUBLE) :: DMHH + INTEGER :: NM1, I + REAL(DOUBLE) :: DMHH !----------------------------------------------- ! ! Define constants ! - DMHH = -H*0.5D00 + DMHH = -H*0.5D00 ! ! Set up arrays XU and XV; since XU(1), XV(1) are never used, ! set them to some arbitrary value ! - NM1 = N - 1 - XU(1) = 0.0D00 - XV(1) = 0.0D00 + NM1 = N - 1 + XU(1) = 0.0D00 + XV(1) = 0.0D00 XU(2:NM1) = DMHH*(XP(3:NM1+1)*RPOR(3:NM1+1)+XP(2:NM1)*RPOR(2:NM1)) + DP(2& - :NM1) + :NM1) XV(2:NM1) = DMHH*(XQ(3:NM1+1)*RPOR(3:NM1+1)+XQ(2:NM1)*RPOR(2:NM1)) + DQ(2& - :NM1) + :NM1) ! - XU(N) = DMHH*XP(N)*RPOR(N) + DP(N) - XV(N) = DMHH*XP(N)*RPOR(N) + DQ(N) + XU(N) = DMHH*XP(N)*RPOR(N) + DP(N) + XV(N) = DMHH*XP(N)*RPOR(N) + DQ(N) ! - RETURN - END SUBROUTINE SETXUV + RETURN + END SUBROUTINE SETXUV diff --git a/src/appl/rmcdhf90_mpi/setxuv_I.f90 b/src/appl/rmcdhf90_mpi/setxuv_I.f90 index f4de1f63c..45b398510 100644 --- a/src/appl/rmcdhf90_mpi/setxuv_I.f90 +++ b/src/appl/rmcdhf90_mpi/setxuv_I.f90 @@ -1,10 +1,10 @@ - MODULE setxuv_I + MODULE setxuv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxuv (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxuv (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setxv.f90 b/src/appl/rmcdhf90_mpi/setxv.f90 index af4557601..5c4624bec 100644 --- a/src/appl/rmcdhf90_mpi/setxv.f90 +++ b/src/appl/rmcdhf90_mpi/setxv.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETXV(J) + SUBROUTINE SETXV(J) ! * ! This subprogram sets up the inhomogeneous terms for the varia- * ! tion equations. * @@ -8,13 +8,13 @@ SUBROUTINE SETXV(J) ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE grid_C USE int_C @@ -23,26 +23,26 @@ SUBROUTINE SETXV(J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: HHC + INTEGER :: I + REAL(DOUBLE) :: HHC !----------------------------------------------- ! - HHC = 0.5D00*H/C + HHC = 0.5D00*H/C ! ! Set up arrays TF and TG ! - DO I = 1, N - XU(I) = -QF(I,J)*HHC*RP(I) - XV(I) = PF(I,J)*HHC*RP(I) - END DO + DO I = 1, N + XU(I) = -QF(I,J)*HHC*RP(I) + XV(I) = PF(I,J)*HHC*RP(I) + END DO ! - XU(:N-1) = XU(2:N) + XU(:N-1) - XV(:N-1) = XV(2:N) + XV(:N-1) + XU(:N-1) = XU(2:N) + XU(:N-1) + XV(:N-1) = XV(2:N) + XV(:N-1) ! - RETURN + RETURN ! - END SUBROUTINE SETXV + END SUBROUTINE SETXV diff --git a/src/appl/rmcdhf90_mpi/setxv_I.f90 b/src/appl/rmcdhf90_mpi/setxv_I.f90 index 1678dbf72..7014adafd 100644 --- a/src/appl/rmcdhf90_mpi/setxv_I.f90 +++ b/src/appl/rmcdhf90_mpi/setxv_I.f90 @@ -1,10 +1,10 @@ - MODULE setxv_I + MODULE setxv_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxv (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxv (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/setxz.f90 b/src/appl/rmcdhf90_mpi/setxz.f90 index b3946e541..40826c52f 100644 --- a/src/appl/rmcdhf90_mpi/setxz.f90 +++ b/src/appl/rmcdhf90_mpi/setxz.f90 @@ -1,30 +1,30 @@ !*********************************************************************** ! * - SUBROUTINE SETXZ(J) + SUBROUTINE SETXZ(J) ! * ! This subprogram sets the inhomogeneous terms to zero. * ! * ! Written by Farid A Parpia, at Oxford Last update: 17 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE int_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! - XU(:N) = 0.0D00 - XV(:N) = 0.0D00 + XU(:N) = 0.0D00 + XV(:N) = 0.0D00 ! - RETURN - END SUBROUTINE SETXZ + RETURN + END SUBROUTINE SETXZ diff --git a/src/appl/rmcdhf90_mpi/setxz_I.f90 b/src/appl/rmcdhf90_mpi/setxz_I.f90 index 51304a838..ac0ae9e34 100644 --- a/src/appl/rmcdhf90_mpi/setxz_I.f90 +++ b/src/appl/rmcdhf90_mpi/setxz_I.f90 @@ -1,10 +1,10 @@ - MODULE setxz_I + MODULE setxz_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setxz (J) - INTEGER :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setxz (J) + INTEGER :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/solve.f90 b/src/appl/rmcdhf90_mpi/solve.f90 index e01bf6742..a3e974947 100644 --- a/src/appl/rmcdhf90_mpi/solve.f90 +++ b/src/appl/rmcdhf90_mpi/solve.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) + SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) ! * ! This subroutine performs step 2 in Algorithm 5.2 and 5.3 of C * ! Froese Fischer, Comput Phys Rep 3 (1986) 295. Some minor changes * @@ -20,13 +20,13 @@ SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) ! Written by Farid A Parpia, at Oxford Last update: 26 Sep 1993 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE debug_C USE def_C, ONLY: C, NSOLV @@ -43,317 +43,317 @@ SUBROUTINE SOLVE(J, FAIL, INV, JP, NNP) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE estim_I - USE eigen_I - USE dcbsrw_I - USE setpot_I - USE setxz_I - USE start_I - USE out_I - USE in_I - USE setxuv_I - USE quad_I - USE setxv_I - USE prwf_I - USE count_I - USE newe_I + USE estim_I + USE eigen_I + USE dcbsrw_I + USE setpot_I + USE setxz_I + USE start_I + USE out_I + USE in_I + USE setxuv_I + USE quad_I + USE setxv_I + USE prwf_I + USE count_I + USE newe_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: INV - INTEGER :: JP - INTEGER :: NNP - LOGICAL :: FAIL + INTEGER :: J + INTEGER :: INV + INTEGER :: JP + INTEGER :: NNP + LOGICAL :: FAIL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KOUNT, NAKJ, NLOOPS, ICASE, MTPH, MTPI, I, MTPC, MTPV, MTPVC, & - LOC1, LOC2, LOC, MX, NPRIME - REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH, PV, QV + LOC1, LOC2, LOC, MX, NPRIME + REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH, PV, QV REAL(DOUBLE) :: TWOCSQ, ELAST, TENEJ, DELEPS, SGN, QJPOH, QJPIH, QJPOI, & QJPII, DNORM, ALFA, P0H, P0V, Q0V, QJPOV, QJPIV, CRNORM, DVNORM, AA, & BB, CC, DISCR, QQ, ROOT1, ROOT2, PMX, APM, PATI, ABPI, RATIO, TEST1, & - TEST2, DELE - LOGICAL :: CHECK + TEST2, DELE + LOGICAL :: CHECK !----------------------------------------------- ! ! Initialization ! - CHECK = .NOT.NOINVT(J) - FAIL = .FALSE. - KOUNT = 0 - NAKJ = NAK(J) + CHECK = .NOT.NOINVT(J) + FAIL = .FALSE. + KOUNT = 0 + NAKJ = NAK(J) ! TWOCSQ = 2.0D 00*137.036**2 - TWOCSQ = 2.0D00*C*C + TWOCSQ = 2.0D00*C*C ! ! Debug header ! - IF (LDBPR(22)) WRITE (99, 300) NP(J), NH(J) + IF (LDBPR(22)) WRITE (99, 300) NP(J), NH(J) ! - NLOOPS = MAX(NSOLV,3*NP(J)) + NLOOPS = MAX(NSOLV,3*NP(J)) ! - CALL ESTIM (J) - ELAST = E(J) - E(J) = EIGEN(J) + CALL ESTIM (J) + ELAST = E(J) + E(J) = EIGEN(J) ! ! Checks on lower bounds ! - IF (E(J) < EPSMIN) THEN - IF (E(J) > 0.0D00) THEN - EPSMIN = E(J) - ELSE - WRITE (*, 301) NP(J), NH(J), E(J) - E(J) = EPSMIN - IF (ABS(EMIN - ELAST)<=1.0D-06 .AND. METHOD(J)<=2) THEN - CALL DCBSRW (NP(J), NAKJ, ZINF, E(J), P0, P, Q, MTP0) - WRITE (*, 302) NP(J), NH(J), ZINF - RETURN - ENDIF - ENDIF - ENDIF + IF (E(J) < EPSMIN) THEN + IF (E(J) > 0.0D00) THEN + EPSMIN = E(J) + ELSE + WRITE (*, 301) NP(J), NH(J), E(J) + E(J) = EPSMIN + IF (ABS(EMIN - ELAST)<=1.0D-06 .AND. METHOD(J)<=2) THEN + CALL DCBSRW (NP(J), NAKJ, ZINF, E(J), P0, P, Q, MTP0) + WRITE (*, 302) NP(J), NH(J), ZINF + RETURN + ENDIF + ENDIF + ENDIF ! ! Check on upper bound ! - IF (METHOD(J) <= 2) THEN - IF (E(J) > EPSMAX) THEN - TENEJ = 10.0D00*E(J) - EPSMAX = MIN(TENEJ,TWOCSQ) - EMAX = EPSMAX - IF (E(J) > TWOCSQ) THEN - WRITE (*, 303) NP(J), NH(J), E(J) - E(J) = TWOCSQ - ENDIF - ENDIF - ENDIF + IF (METHOD(J) <= 2) THEN + IF (E(J) > EPSMAX) THEN + TENEJ = 10.0D00*E(J) + EPSMAX = MIN(TENEJ,TWOCSQ) + EMAX = EPSMAX + IF (E(J) > TWOCSQ) THEN + WRITE (*, 303) NP(J), NH(J), E(J) + E(J) = TWOCSQ + ENDIF + ENDIF + ENDIF ! ! Iteration loop begins here ! - 1 CONTINUE - KOUNT = KOUNT + 1 + 1 CONTINUE + KOUNT = KOUNT + 1 ! - P0 = PZ(J) + P0 = PZ(J) ! - IF (KOUNT > 1) THEN + IF (KOUNT > 1) THEN ! ! Check that bounds are ordered correctly ! IF (EPSMAX <= EPSMIN) WRITE (*, 304) EPSMIN, EPSMAX, NP(J), NH(J), E(J& - ) + ) ! - IF (KOUNT>NLOOPS .OR. EPSMAX-EPSMIN<1.0D00/DBLE(NP(J))**3) THEN - WRITE (*, 305) METHOD(J), NP(J), NH(J) + IF (KOUNT>NLOOPS .OR. EPSMAX-EPSMIN<1.0D00/DBLE(NP(J))**3) THEN + WRITE (*, 305) METHOD(J), NP(J), NH(J) WRITE (*, 306) KOUNT - 1, NLOOPS, P0, E(J), DELEPS, EPSMIN, EPSMAX& - , JP, MTP, NNP, NNODEP(J), SGN - FAIL = .TRUE. - RETURN - ENDIF - ENDIF + , JP, MTP, NNP, NNODEP(J), SGN + FAIL = .TRUE. + RETURN + ENDIF + ENDIF ! ! Set up arrays TF and TG; find join point ! - CALL SETPOT (J, JP) + CALL SETPOT (J, JP) ! ! Set right-hand side to zero to form homogeneous equations; ! integrate homogeneous equations outwards and inwards; store ! small component at join point each time ! - CALL SETXZ (J) - ICASE = 1 - CALL START (J, ICASE, P0, PH, Q0, QH) - CALL OUT (J, JP, PH, QH) - QJPOH = QH(JP) - CALL IN (J, JP, PH, QH, MTPH) - QJPIH = QH(JP) + CALL SETXZ (J) + ICASE = 1 + CALL START (J, ICASE, P0, PH, Q0, QH) + CALL OUT (J, JP, PH, QH) + QJPOH = QH(JP) + CALL IN (J, JP, PH, QH, MTPH) + QJPIH = QH(JP) ! ! Set up right-hand side for inhomogeneous equations; integrate ! inhomogeneous equations outwards and inwards; store small ! component at join point each time ! - CALL SETXUV (J) - ICASE = 2 - CALL START (J, ICASE, P0, P, Q0, Q) - CALL OUT (J, JP, P, Q) - QJPOI = Q(JP) - CALL IN (J, JP, P, Q, MTPI) - QJPII = Q(JP) + CALL SETXUV (J) + ICASE = 2 + CALL START (J, ICASE, P0, P, Q0, Q) + CALL OUT (J, JP, P, Q) + QJPOI = Q(JP) + CALL IN (J, JP, P, Q, MTPI) + QJPII = Q(JP) ! ! Determine energy adjustment for methods 1 and 2 ! - IF (METHOD(J) <= 2) THEN - TA(1) = 0.0D00 - TA(2:MTPI) = (P(2:MTPI)**2+Q(2:MTPI)**2)*RP(2:MTPI) - MTP = MTPI - CALL QUAD (DNORM) + IF (METHOD(J) <= 2) THEN + TA(1) = 0.0D00 + TA(2:MTPI) = (P(2:MTPI)**2+Q(2:MTPI)**2)*RP(2:MTPI) + MTP = MTPI + CALL QUAD (DNORM) ! DELEPS = 137.036*P(JP)*(QJPII-QJPOI)/DNORM - DELEPS = C*P(JP)*(QJPII - QJPOI)/DNORM - ENDIF + DELEPS = C*P(JP)*(QJPII - QJPOI)/DNORM + ENDIF ! ! Generate the continuous solution ! - MTPC = MAX(MTPH,MTPI) - ALFA = -(QJPII - QJPOI)/(QJPIH - QJPOH) - P0H = P0 - P0 = P0*(1.0D00 + ALFA) - P(:MTPC) = P(:MTPC) + ALFA*PH(:MTPC) - Q(:MTPC) = Q(:MTPC) + ALFA*QH(:MTPC) + MTPC = MAX(MTPH,MTPI) + ALFA = -(QJPII - QJPOI)/(QJPIH - QJPOH) + P0H = P0 + P0 = P0*(1.0D00 + ALFA) + P(:MTPC) = P(:MTPC) + ALFA*PH(:MTPC) + Q(:MTPC) = Q(:MTPC) + ALFA*QH(:MTPC) ! - IF (METHOD(J)==2 .OR. METHOD(J)==4) THEN + IF (METHOD(J)==2 .OR. METHOD(J)==4) THEN ! ! Set up right-hand side for variational equations; integrate ! variational equations outwards and inwards; store small ! component at join point each time ! - P0V = 0.0D00 - CALL SETXV (J) - ICASE = 3 - CALL START (J, ICASE, P0V, PV, Q0V, QV) - CALL OUT (J, JP, PV, QV) - QJPOV = QV(JP) - CALL IN (J, JP, PV, QV, MTPV) - QJPIV = QV(JP) + P0V = 0.0D00 + CALL SETXV (J) + ICASE = 3 + CALL START (J, ICASE, P0V, PV, Q0V, QV) + CALL OUT (J, JP, PV, QV) + QJPOV = QV(JP) + CALL IN (J, JP, PV, QV, MTPV) + QJPIV = QV(JP) ! ! Generate continuous solutions ! - MTPVC = MAX(MTPC,MTPV) - ALFA = -(QJPIV - QJPOV)/(QJPIH - QJPOH) - PV(:MTPVC) = PV(:MTPVC) + ALFA*PH(:MTPVC) - QV(:MTPVC) = QV(:MTPVC) + ALFA*QH(:MTPVC) + MTPVC = MAX(MTPC,MTPV) + ALFA = -(QJPIV - QJPOV)/(QJPIH - QJPOH) + PV(:MTPVC) = PV(:MTPVC) + ALFA*PH(:MTPVC) + QV(:MTPVC) = QV(:MTPVC) + ALFA*QH(:MTPVC) ! - TA(1) = 0.0D00 - TA(2:MTPC) = RP(2:MTPC)*(P(2:MTPC)**2+Q(2:MTPC)**2) - MTP = MTPC - CALL QUAD (DNORM) + TA(1) = 0.0D00 + TA(2:MTPC) = RP(2:MTPC)*(P(2:MTPC)**2+Q(2:MTPC)**2) + MTP = MTPC + CALL QUAD (DNORM) ! - MTP = MIN(MTPC,MTPVC) - TA(1) = 0.0D00 - TA(2:MTP) = RP(2:MTP)*(P(2:MTP)*PV(2:MTP)+Q(2:MTP)*QV(2:MTP)) - CALL QUAD (CRNORM) + MTP = MIN(MTPC,MTPVC) + TA(1) = 0.0D00 + TA(2:MTP) = RP(2:MTP)*(P(2:MTP)*PV(2:MTP)+Q(2:MTP)*QV(2:MTP)) + CALL QUAD (CRNORM) ! - TA(1) = 0.0D00 - TA(2:MTPVC) = RP(2:MTPVC)*(PV(2:MTPVC)**2+QV(2:MTPVC)**2) - MTP = MTPVC - CALL QUAD (DVNORM) + TA(1) = 0.0D00 + TA(2:MTPVC) = RP(2:MTPVC)*(PV(2:MTPVC)**2+QV(2:MTPVC)**2) + MTP = MTPVC + CALL QUAD (DVNORM) ! ! Determine deleps required to normalize new solution to ! first order: modified form of solution to a quadratic ! equation (see Press et al.) ! - AA = DVNORM - BB = CRNORM + CRNORM - CC = DNORM - 1.0D00 - DISCR = BB*BB - 4.0D00*AA*CC - IF (DISCR > 0.0D00) THEN - QQ = -0.5D00*(BB + SIGN(1.0D00,BB)*SQRT(DISCR)) - ROOT1 = CC/QQ - ROOT2 = QQ/AA - PMX = 0.0D00 - APM = 0.0D00 - DO I = 2, JP - PATI = P(I) - IF (PATI > PMX) THEN - PMX = PATI - LOC1 = I - ENDIF - ABPI = ABS(PATI) - IF (ABPI <= APM) CYCLE - APM = ABPI - LOC2 = I - END DO - IF (PMX /= 0.0D00) THEN - RATIO = APM/ABS(PMX) - IF (RATIO < 10.0D00) THEN - LOC = LOC1 - ELSE - LOC = LOC2 - ENDIF - ELSE - LOC = LOC2 - ENDIF - TEST1 = P(LOC) + ROOT1*PV(LOC) - TEST2 = P(LOC) + ROOT2*PV(LOC) - IF (TEST1>0.0D00 .AND. TEST2<0.0D00) THEN - DELE = ROOT1 - ELSE IF (TEST1<0.0D00 .AND. TEST2>0.0D00) THEN - DELE = ROOT2 - ELSE IF (TEST1>0.0D00 .AND. TEST2>0.0D00) THEN - IF (TEST1 < TEST2) THEN - DELE = ROOT1 - ELSE - DELE = ROOT2 - ENDIF - ELSE IF (TEST1<0.0D00 .AND. TEST2<0.0D00) THEN - IF (TEST1 > TEST2) THEN - DELE = ROOT1 - ELSE - DELE = ROOT2 - ENDIF - ENDIF - ELSE - DELE = -BB/(AA + AA) - ENDIF + AA = DVNORM + BB = CRNORM + CRNORM + CC = DNORM - 1.0D00 + DISCR = BB*BB - 4.0D00*AA*CC + IF (DISCR > 0.0D00) THEN + QQ = -0.5D00*(BB + SIGN(1.0D00,BB)*SQRT(DISCR)) + ROOT1 = CC/QQ + ROOT2 = QQ/AA + PMX = 0.0D00 + APM = 0.0D00 + DO I = 2, JP + PATI = P(I) + IF (PATI > PMX) THEN + PMX = PATI + LOC1 = I + ENDIF + ABPI = ABS(PATI) + IF (ABPI <= APM) CYCLE + APM = ABPI + LOC2 = I + END DO + IF (PMX /= 0.0D00) THEN + RATIO = APM/ABS(PMX) + IF (RATIO < 10.0D00) THEN + LOC = LOC1 + ELSE + LOC = LOC2 + ENDIF + ELSE + LOC = LOC2 + ENDIF + TEST1 = P(LOC) + ROOT1*PV(LOC) + TEST2 = P(LOC) + ROOT2*PV(LOC) + IF (TEST1>0.0D00 .AND. TEST2<0.0D00) THEN + DELE = ROOT1 + ELSE IF (TEST1<0.0D00 .AND. TEST2>0.0D00) THEN + DELE = ROOT2 + ELSE IF (TEST1>0.0D00 .AND. TEST2>0.0D00) THEN + IF (TEST1 < TEST2) THEN + DELE = ROOT1 + ELSE + DELE = ROOT2 + ENDIF + ELSE IF (TEST1<0.0D00 .AND. TEST2<0.0D00) THEN + IF (TEST1 > TEST2) THEN + DELE = ROOT1 + ELSE + DELE = ROOT2 + ENDIF + ENDIF + ELSE + DELE = -BB/(AA + AA) + ENDIF ! ! Generate new solution ! - MTP0 = MAX(MTPC,MTPVC) - P0 = P0 + DELE*ALFA*P0H - P(2:MTP0) = P(2:MTP0) + DELE*PV(2:MTP0) - Q(2:MTP0) = Q(2:MTP0) + DELE*QV(2:MTP0) - ELSE - MTP0 = MTPC - ENDIF + MTP0 = MAX(MTPC,MTPVC) + P0 = P0 + DELE*ALFA*P0H + P(2:MTP0) = P(2:MTP0) + DELE*PV(2:MTP0) + Q(2:MTP0) = Q(2:MTP0) + DELE*QV(2:MTP0) + ELSE + MTP0 = MTPC + ENDIF ! ! Debug printout ! - IF (LDBPR(23)) CALL PRWF (J) + IF (LDBPR(23)) CALL PRWF (J) ! ! Count nodes in large component function; determine sign at first ! oscillation, effective quantum number; note that node counting ! is never enforced on the small component ! - CALL COUNT (P, MTP0, NNP, SGN) + CALL COUNT (P, MTP0, NNP, SGN) ! ! DEBUG PRINTOUT ! IF (LDBPR(22)) WRITE (99, 306) KOUNT, NLOOPS, P0, E(J), DELEPS, EPSMIN, & - EPSMAX, JP, MTP, NNP, NNODEP(J), SGN + EPSMAX, JP, MTP, NNP, NNODEP(J), SGN ! ! Proceed according to method ! - IF (METHOD(J) > 2) THEN - IF (CHECK .AND. SGN<0.0D00) THEN - INV = 1 - P0 = -P0 - P(2:MTP0) = -P(2:MTP0) - Q(2:MTP0) = -Q(2:MTP0) - ENDIF - ELSE - MX = NNP - NNODEP(J) - NPRIME = NNP + NKL(J) + 1 - CALL NEWE (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) - IF (FAIL) GO TO 1 - ENDIF + IF (METHOD(J) > 2) THEN + IF (CHECK .AND. SGN<0.0D00) THEN + INV = 1 + P0 = -P0 + P(2:MTP0) = -P(2:MTP0) + Q(2:MTP0) = -Q(2:MTP0) + ENDIF + ELSE + MX = NNP - NNODEP(J) + NPRIME = NNP + NKL(J) + 1 + CALL NEWE (J, SGN, NPRIME, MX, DELEPS, FAIL, INV) + IF (FAIL) GO TO 1 + ENDIF ! ! Solution found ! - RETURN + RETURN ! - 300 FORMAT(/,/,' Debug printout active; orbital: ',1I2,1A2) - 301 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to EPSMIN') + 300 FORMAT(/,/,' Debug printout active; orbital: ',1I2,1A2) + 301 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to EPSMIN') 302 FORMAT(' Returned hydrogenic function for ',1I2,1A2,' with',& - ' effective charge ',F7.3) - 303 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to TWOCSQ') + ' effective charge ',F7.3) + 303 FORMAT(' E(',1I2,1A2,') = ',1P,D11.4,'; adjusted to TWOCSQ') 304 FORMAT(' Warning: difficulty with node-counting procedure'/,& ' lower bound on energy (',1P,D11.4,') exceeds upper',' bound (',1D& - 11.4,'; E(',1I2,1A2,') = ',1D11.4) - 305 FORMAT(' Method ',1I1,' unable to solve for ',1I2,1A2,' orbital') + 11.4,'; E(',1I2,1A2,') = ',1D11.4) + 305 FORMAT(' Method ',1I1,' unable to solve for ',1I2,1A2,' orbital') 306 FORMAT(' Iteration number: ',1I2,', limit: ',1I2,/,& ' Present estimate of P0; ',1D21.14,/,' Present estimate of E(J): ',1D& 21.14,', DELEPS: ',1D21.14,/,' Lower bound on energy: ',1D21.14,& ', upper bound: ',1D21.14,/,' Join point: ',1I4,& ', Maximum tabulation point:',1I4,/,' Number of nodes counted: ',1I2,& - ', Correct number: ',1I2,/,' Sign of P at first oscillation: ',F3.0) - RETURN + ', Correct number: ',1I2,/,' Sign of P at first oscillation: ',F3.0) + RETURN ! - END SUBROUTINE SOLVE + END SUBROUTINE SOLVE diff --git a/src/appl/rmcdhf90_mpi/solve_I.f90 b/src/appl/rmcdhf90_mpi/solve_I.f90 index 65bf03b1e..c126a3ca8 100644 --- a/src/appl/rmcdhf90_mpi/solve_I.f90 +++ b/src/appl/rmcdhf90_mpi/solve_I.f90 @@ -1,14 +1,14 @@ - MODULE solve_I + MODULE solve_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE solve (J, FAIL, INV, JP, NNP) - INTEGER, INTENT(IN) :: J - LOGICAL, INTENT(OUT) :: FAIL - INTEGER, INTENT(OUT) :: INV - INTEGER, INTENT(IN) :: JP - INTEGER, INTENT(IN) :: NNP - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE solve (J, FAIL, INV, JP, NNP) + INTEGER, INTENT(IN) :: J + LOGICAL, INTENT(OUT) :: FAIL + INTEGER, INTENT(OUT) :: INV + INTEGER, INTENT(IN) :: JP + INTEGER, INTENT(IN) :: NNP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/strsum.f90 b/src/appl/rmcdhf90_mpi/strsum.f90 index 84d2c6bba..e0478a695 100644 --- a/src/appl/rmcdhf90_mpi/strsum.f90 +++ b/src/appl/rmcdhf90_mpi/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** - SUBROUTINE STRSUM - + SUBROUTINE STRSUM + ! Generates the first part of rscf92.sum (on stream 24). ! ! Call(s) to: [LIB92] CALEN, CONVRT. @@ -8,13 +8,13 @@ SUBROUTINE STRSUM ! Written by Farid A. Parpia Last revision: 26 Sep 1993 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE foparm_C USE grid_C @@ -28,13 +28,13 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, IEND, I, IBEG - CHARACTER :: RECORD*256, CDATA*26, CTIME*8, CDATE*8, CLEVEL*2 + INTEGER :: LENTH, IEND, I, IBEG + CHARACTER :: RECORD*256, CDATA*26, CTIME*8, CDATE*8, CLEVEL*2 !----------------------------------------------- ! ! POINTER (PWEIGH,WEIGHT(1)) @@ -45,7 +45,7 @@ SUBROUTINE STRSUM ! Both the nuclear charge and the number of electrons are ! known at this point; load IONCTY with the ionicity ! - IONCTY = NINT(Z) - NELEC + IONCTY = NINT(Z) - NELEC ! ! Get the date and time of day; make this information the ! header of the summary file @@ -55,117 +55,117 @@ SUBROUTINE STRSUM ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (LFORDR) THEN - WRITE (24, *) - CALL CONVRT (ICCUT, RECORD, LENTH) + IF (LFORDR) THEN + WRITE (24, *) + CALL CONVRT (ICCUT, RECORD, LENTH) WRITE (24, *) ' CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space;' - ENDIF + ' the zero-order space;' + ENDIF ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z - IF (EMN == 0.D0) THEN - WRITE (24, *) ' the nucleus is stationary;' - ELSE - WRITE (24, 301) EMN - ENDIF - IF (NPARM == 2) THEN - WRITE (24, *) ' Fermi nucleus:' - WRITE (24, 302) PARM(1), PARM(2) - CALL CONVRT (NNUC, RECORD, LENTH) + WRITE (24, *) + WRITE (24, 300) Z + IF (EMN == 0.D0) THEN + WRITE (24, *) ' the nucleus is stationary;' + ELSE + WRITE (24, 301) EMN + ENDIF + IF (NPARM == 2) THEN + WRITE (24, *) ' Fermi nucleus:' + WRITE (24, 302) PARM(1), PARM(2) + CALL CONVRT (NNUC, RECORD, LENTH) WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 303) C + WRITE (24, *) + WRITE (24, 303) C ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.D0) THEN - WRITE (24, 305) RNT, H, N - ELSE - WRITE (24, 306) RNT, H, HP, N - ENDIF - WRITE (24, 307) R(1), R(2), R(N) - WRITE (24, *) + WRITE (24, *) + IF (HP == 0.D0) THEN + WRITE (24, 305) RNT, H, N + ELSE + WRITE (24, 306) RNT, H, HP, N + ENDIF + WRITE (24, 307) R(1), R(2), R(N) + WRITE (24, *) ! ! (E)AL calculation, returns here ! - IF (NCMIN == 0) THEN - WRITE (24, *) '(E)AL calculation.' - RETURN - ENDIF + IF (NCMIN == 0) THEN + WRITE (24, *) '(E)AL calculation.' + RETURN + ENDIF ! ! Info exclusively for EOL calculations ! - IF (NCMIN == 1) THEN - WRITE (24, *) 'OL calculation.' - CALL CONVRT (ICCMIN(1), RECORD, LENTH) - WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be optimised.' - ELSE - WRITE (24, *) 'EOL calculation.' - CALL CONVRT (NCMIN, RECORD, LENTH) - WRITE (24, *) RECORD(1:LENTH)//' levels will be optimised;' - RECORD(1:20) = ' their indices are: ' - IEND = 20 - DO I = 1, NCMIN - IBEG = IEND + 1 - CALL CONVRT (ICCMIN(I), CLEVEL, LENTH) - IF (I /= NCMIN) THEN - IEND = IBEG + LENTH + 1 - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' - ELSE - IEND = IBEG + LENTH - RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' - ENDIF - IF (IEND < 120) CYCLE - WRITE (24, *) RECORD(1:IEND) - RECORD(1:2) = ' ' - IEND = 2 - END DO - IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) - IF (WEIGHT(1) == (-1.D0)) THEN - WRITE (24, *) 'Each is assigned its statistical weight;' - ELSE IF (WEIGHT(1) == (-2.D0)) THEN - WRITE (24, *) 'All levels are weighted equally;' - ELSE - WRITE (24, *) ' weighted as follows:' - WRITE (24, *) (WEIGHT(I),I=1,NCMIN) - ENDIF - ENDIF - - 300 FORMAT('The atomic number is ',1F14.10,';') - 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') - 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 303 FORMAT('Speed of light = ',3P,D19.12,' atomic units.') + IF (NCMIN == 1) THEN + WRITE (24, *) 'OL calculation.' + CALL CONVRT (ICCMIN(1), RECORD, LENTH) + WRITE (24, *) 'Level '//RECORD(1:LENTH)//' will be optimised.' + ELSE + WRITE (24, *) 'EOL calculation.' + CALL CONVRT (NCMIN, RECORD, LENTH) + WRITE (24, *) RECORD(1:LENTH)//' levels will be optimised;' + RECORD(1:20) = ' their indices are: ' + IEND = 20 + DO I = 1, NCMIN + IBEG = IEND + 1 + CALL CONVRT (ICCMIN(I), CLEVEL, LENTH) + IF (I /= NCMIN) THEN + IEND = IBEG + LENTH + 1 + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//', ' + ELSE + IEND = IBEG + LENTH + RECORD(IBEG:IEND) = CLEVEL(1:LENTH)//'.' + ENDIF + IF (IEND < 120) CYCLE + WRITE (24, *) RECORD(1:IEND) + RECORD(1:2) = ' ' + IEND = 2 + END DO + IF (IEND /= 2) WRITE (24, *) RECORD(1:IEND) + IF (WEIGHT(1) == (-1.D0)) THEN + WRITE (24, *) 'Each is assigned its statistical weight;' + ELSE IF (WEIGHT(1) == (-2.D0)) THEN + WRITE (24, *) 'All levels are weighted equally;' + ELSE + WRITE (24, *) ' weighted as follows:' + WRITE (24, *) (WEIGHT(I),I=1,NCMIN) + ENDIF + ENDIF + + 300 FORMAT('The atomic number is ',1F14.10,';') + 301 FORMAT(' the mass of the nucleus is ',1P,D19.12,' electron masses;') + 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 303 FORMAT('Speed of light = ',3P,D19.12,' atomic units.') 305 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 306 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 307 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') - - RETURN - END SUBROUTINE STRSUM + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + + RETURN + END SUBROUTINE STRSUM diff --git a/src/appl/rmcdhf90_mpi/strsum_I.f90 b/src/appl/rmcdhf90_mpi/strsum_I.f90 index e75d8b2d0..1ec5c8f52 100644 --- a/src/appl/rmcdhf90_mpi/strsum_I.f90 +++ b/src/appl/rmcdhf90_mpi/strsum_I.f90 @@ -1,10 +1,10 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum + SUBROUTINE strsum !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/xpot.f90 b/src/appl/rmcdhf90_mpi/xpot.f90 index 912f2f2e9..bb2a184e5 100644 --- a/src/appl/rmcdhf90_mpi/xpot.f90 +++ b/src/appl/rmcdhf90_mpi/xpot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE XPOT(J) + SUBROUTINE XPOT(J) ! * ! This subroutine tabulates the exchange terms (the first terms on * ! the right-hand sides of eqs (14), I P Grant, B J McKenzie, P H * @@ -13,11 +13,11 @@ SUBROUTINE XPOT(J) ! Written by Farid A Parpia, at Oxford Last update: 10 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB @@ -32,99 +32,99 @@ SUBROUTINE XPOT(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE yzk_I - USE draw_I + USE yzk_I + USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I,INDEX,LABEL,K,IOY1,IOY2,IORB,NB2,NROWS,II,II1,II2,MFI - REAL(DOUBLE) :: COEFF, CTB + REAL(DOUBLE) :: COEFF, CTB !----------------------------------------------- ! ! Debug printout: header ! - IF (LDBPR(27) .OR. LDBPR(28)) WRITE (99, 300) NP(J), NH(J) + IF (LDBPR(27) .OR. LDBPR(28)) WRITE (99, 300) NP(J), NH(J) ! ! Clear for accumulation of sums ! - XP(:N) = 0.D0 - XQ(:N) = 0.D0 + XP(:N) = 0.D0 + XQ(:N) = 0.D0 ! ! Add contributions from exchange terms ! - DO INDEX = 1, NXCOF - + DO INDEX = 1, NXCOF + ! Decode information in label - LABEL = NXA(INDEX) - K = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY1 = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY2 = MOD(LABEL,KEY) - IORB = LABEL/KEY - COEFF = XA(INDEX) - + LABEL = NXA(INDEX) + K = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY1 = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY2 = MOD(LABEL,KEY) + IORB = LABEL/KEY + COEFF = XA(INDEX) + ! Debug printout: composition IF (LDBPR(27)) WRITE (99, 301) K, COEFF, NP(IOY1), NH(IOY1), NP(IOY2)& - , NH(IOY2), NP(IORB), NH(IORB) - - CALL YZK (K, IOY1, IOY2) + , NH(IOY2), NP(IORB), NH(IORB) + + CALL YZK (K, IOY1, IOY2) ! ! Accumulate contributions ! MFI = MF(IORB) - COEFF = COEFF/C + COEFF = COEFF/C !DO I = 1, MF(IORB) - DO I = 1, MFI -!GG DO I = 1, N - CTB = COEFF*TB(I) - XP(I) = XP(I) + CTB*QF(I,IORB) - XQ(I) = XQ(I) - CTB*PF(I,IORB) - END DO - END DO + DO I = 1, MFI +!GG DO I = 1, N + CTB = COEFF*TB(I) + XP(I) = XP(I) + CTB*QF(I,IORB) + XQ(I) = XQ(I) - CTB*PF(I,IORB) + END DO + END DO ! ! Debug printout: potential functions ! - IF (LDBPR(28)) THEN - WRITE (99, 302) - NB2 = N/2 - IF (2*NB2 == N) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= N) THEN + IF (LDBPR(28)) THEN + WRITE (99, 302) + NB2 = N/2 + IF (2*NB2 == N) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= N) THEN WRITE (99, 303) R(II1), XP(II1), XQ(II1), R(II2), XP(II2), XQ(& - II2) - ELSE IF (II1 <= N) THEN - WRITE (99, 303) R(II1), XP(II1), XQ(II1) - ENDIF - END DO - CALL DRAW (XP, 1.0D00, XQ, C, N) - ENDIF + II2) + ELSE IF (II1 <= N) THEN + WRITE (99, 303) R(II1), XP(II1), XQ(II1) + ENDIF + END DO + CALL DRAW (XP, 1.0D00, XQ, C, N) + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,/,' Exchange potential contributions (coefficients will ',& - ' be divided by C) for ',1I2,1A2,' orbital :'/,/) + ' be divided by C) for ',1I2,1A2,' orbital :'/,/) 301 FORMAT(/,25X,'(',1I2,')'/,1X,1P,D21.14,'* Y (',1I2,1A2,',',1I2,1A2,& - ') ','* P (',1I2,1A2,')') + ') ','* P (',1I2,1A2,')') 302 FORMAT(/,/,31X,'(P)',19X,'(Q)',41X,'(P)',19X,'(Q)'/,2(& ' --------- r --------- ------ X (r) -------',& - ' ------ X (r) -------')) - 303 FORMAT(1P,6(1X,1D21.14)) - RETURN + ' ------ X (r) -------')) + 303 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE XPOT + END SUBROUTINE XPOT diff --git a/src/appl/rmcdhf90_mpi/xpot_I.f90 b/src/appl/rmcdhf90_mpi/xpot_I.f90 index f999e432f..582029e32 100644 --- a/src/appl/rmcdhf90_mpi/xpot_I.f90 +++ b/src/appl/rmcdhf90_mpi/xpot_I.f90 @@ -1,11 +1,11 @@ - MODULE xpot_I + MODULE xpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:59:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE xpot (J) - INTEGER, INTENT(IN) :: J + SUBROUTINE xpot (J) + INTEGER, INTENT(IN) :: J !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rmcdhf90_mpi/ypot.f90 b/src/appl/rmcdhf90_mpi/ypot.f90 index e3e642fd9..420b5db4e 100644 --- a/src/appl/rmcdhf90_mpi/ypot.f90 +++ b/src/appl/rmcdhf90_mpi/ypot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE YPOT(J) + SUBROUTINE YPOT(J) ! * ! This subroutine tabulates the potential function Y(r) (Eq (14) * ! in I P Grant, B J McKenzie, P H Norrington, D F Mayers, and N C * @@ -13,11 +13,11 @@ SUBROUTINE YPOT(J) ! MPI version by Xinghong He Last revision: 05 Aug 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB @@ -32,83 +32,83 @@ SUBROUTINE YPOT(J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE yzk_I - USE draw_I + USE yzk_I + USE draw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, NB3, NROWS, II, II1, II2, II3 - REAL(DOUBLE) :: COEFF + INTEGER :: I, INDEX, LABEL, K, IOY1, IOY2, NB3, NROWS, II, II1, II2, II3 + REAL(DOUBLE) :: COEFF !----------------------------------------------- ! Debug printout: composition - - IF (LDBPR(29) .OR. LDBPR(30)) WRITE (99, 300) NP(J), NH(J) + + IF (LDBPR(29) .OR. LDBPR(30)) WRITE (99, 300) NP(J), NH(J) ! ! Initialize array YP with the nuclear potential piece ! ! Since YA() below contains contributions from THIS node only, ! the initialization should be in consistence with that. - + YP(:N) = ZZ(:N) / NPROCS - - DO INDEX = 1, NYCOF - + + DO INDEX = 1, NYCOF + ! Decode information in label - LABEL = NYA(INDEX) - K = MOD(LABEL,KEY) - LABEL = LABEL/KEY - IOY1 = MOD(LABEL,KEY) - IOY2 = LABEL/KEY - COEFF = YA(INDEX) - + LABEL = NYA(INDEX) + K = MOD(LABEL,KEY) + LABEL = LABEL/KEY + IOY1 = MOD(LABEL,KEY) + IOY2 = LABEL/KEY + COEFF = YA(INDEX) + IF (LDBPR(29)) WRITE (99, 301) K, COEFF, NP(IOY1), NH(IOY1), NP(IOY2)& - , NH(IOY2) - - CALL YZK (K, IOY1, IOY2) ! Accumulate contributions - YP(:N) = YP(:N) - COEFF*TB(:N) - END DO + , NH(IOY2) + + CALL YZK (K, IOY1, IOY2) ! Accumulate contributions + YP(:N) = YP(:N) - COEFF*TB(:N) + END DO ! ! Debug printout ! - IF (LDBPR(30)) THEN - WRITE (99, 302) - NB3 = N/3 - IF (3*NB3 == N) THEN - NROWS = NB3 - ELSE - NROWS = NB3 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - II3 = II2 + NROWS - IF (II3 <= N) THEN - WRITE (99, 303) R(II1),YP(II1),R(II2),YP(II2),R(II3),YP(II3) - ELSE IF (II2 <= N) THEN - WRITE (99, 303) R(II1),YP(II1),R(II2),YP(II2) - ELSE - WRITE (99, 303) R(II1),YP(II1) - ENDIF - END DO - CALL DRAW (YP, 1.0D00, YP, 0.0D00, N) - ENDIF + IF (LDBPR(30)) THEN + WRITE (99, 302) + NB3 = N/3 + IF (3*NB3 == N) THEN + NROWS = NB3 + ELSE + NROWS = NB3 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + II3 = II2 + NROWS + IF (II3 <= N) THEN + WRITE (99, 303) R(II1),YP(II1),R(II2),YP(II2),R(II3),YP(II3) + ELSE IF (II2 <= N) THEN + WRITE (99, 303) R(II1),YP(II1),R(II2),YP(II2) + ELSE + WRITE (99, 303) R(II1),YP(II1) + ENDIF + END DO + CALL DRAW (YP, 1.0D00, YP, 0.0D00, N) + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,/,' Direct potential for ',1I2,1A2,' orbital :'/,/) + 300 FORMAT(/,/,' Direct potential for ',1I2,1A2,' orbital :'/,/) 301 FORMAT(/,25X,'(',1I2,')'/,1X,1P,D21.14,'* Y (',1I2,1A2,',',1I2,1A2,')'& - ) - 302 FORMAT(/,/,3(' --------- r --------- ------- Y (r) -------')) - 303 FORMAT(1P,6(1X,1D21.14)) - RETURN + ) + 302 FORMAT(/,/,3(' --------- r --------- ------- Y (r) -------')) + 303 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE YPOT + END SUBROUTINE YPOT diff --git a/src/appl/rmcdhf90_mpi/ypot_I.f90 b/src/appl/rmcdhf90_mpi/ypot_I.f90 index ae9337fc4..dd9535fca 100644 --- a/src/appl/rmcdhf90_mpi/ypot_I.f90 +++ b/src/appl/rmcdhf90_mpi/ypot_I.f90 @@ -1,10 +1,10 @@ - MODULE ypot_I + MODULE ypot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ypot (J) - INTEGER, INTENT(IN) :: J - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ypot (J) + INTEGER, INTENT(IN) :: J + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rnucleus90/Makefile b/src/appl/rnucleus90/Makefile old mode 100755 new mode 100644 index b44146135..3f7ee1147 --- a/src/appl/rnucleus90/Makefile +++ b/src/appl/rnucleus90/Makefile @@ -7,7 +7,7 @@ BINFILE = $(BINDIR)/$(EXE) SRCLIBDIR = ../../lib MODDIR = ${SRCLIBDIR}/libmod MODL9290 = ${SRCLIBDIR}/lib9290 -GRASPLIBS =-l9290 -lmod +GRASPLIBS =-l9290 -lmod APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} @@ -16,7 +16,7 @@ APP_OBJ= \ estrms.o geniso.o getcpr.o skfun.o $(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(iFC_LD) $(APP_OBJ) $(APP_LIBS) + $(FC) -o $(BINFILE) $(iFC_LD) $(APP_OBJ) $(APP_LIBS) .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL9290} -o $@ @@ -25,5 +25,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - - diff --git a/src/appl/rnucleus90/estrms.f90 b/src/appl/rnucleus90/estrms.f90 index 9bf4bd3bf..75e1eb772 100644 --- a/src/appl/rnucleus90/estrms.f90 +++ b/src/appl/rnucleus90/estrms.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION ESTRMS (APARM, CPARM) + REAL(KIND(0.0D0)) FUNCTION ESTRMS (APARM, CPARM) ! * ! Determines the root mean square radius for a Fermi nucleus given * ! the parameters `c' (CPARM) and `a' (APARM). We use the formalism * @@ -14,37 +14,37 @@ REAL(KIND(0.0D0)) FUNCTION ESTRMS (APARM, CPARM) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE skfun_I + USE skfun_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: APARM - REAL(DOUBLE) , INTENT(IN) :: CPARM + REAL(DOUBLE) , INTENT(IN) :: APARM + REAL(DOUBLE) , INTENT(IN) :: CPARM !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: PI, SQTBF, ABC, PABC, CBAM, DNUMER, DDENOM + REAL(DOUBLE) :: PI, SQTBF, ABC, PABC, CBAM, DNUMER, DDENOM !----------------------------------------------- ! - PI = 4.0D00*ATAN(1.0D00) - SQTBF = SQRT(3.0D00/5.0D00) + PI = 4.0D00*ATAN(1.0D00) + SQTBF = SQRT(3.0D00/5.0D00) ! - ABC = APARM/CPARM - PABC = PI*ABC - CBAM = -CPARM/APARM + ABC = APARM/CPARM + PABC = PI*ABC + CBAM = -CPARM/APARM DNUMER = 1.0D00 + (10.0D00/3.0D00)*PABC**2 + (7.0D00/3.0D00)*PABC**4 - & - 120.0D00*ABC**5*SKFUN(5,CBAM) - DDENOM = 1.0D00 + PABC**2 - 6.0D00*ABC**3*SKFUN(3,CBAM) - ESTRMS = CPARM*SQTBF*SQRT(DNUMER/DDENOM) + 120.0D00*ABC**5*SKFUN(5,CBAM) + DDENOM = 1.0D00 + PABC**2 - 6.0D00*ABC**3*SKFUN(3,CBAM) + ESTRMS = CPARM*SQTBF*SQRT(DNUMER/DDENOM) ! - RETURN - END FUNCTION ESTRMS + RETURN + END FUNCTION ESTRMS diff --git a/src/appl/rnucleus90/estrms_I.f90 b/src/appl/rnucleus90/estrms_I.f90 index 54789be09..bff782762 100644 --- a/src/appl/rnucleus90/estrms_I.f90 +++ b/src/appl/rnucleus90/estrms_I.f90 @@ -1,10 +1,10 @@ - MODULE estrms_I + MODULE estrms_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 - REAL(KIND(0.0D0)) FUNCTION estrms (APARM, CPARM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: APARM - REAL(DOUBLE), INTENT(IN) :: CPARM - END FUNCTION - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 + REAL(KIND(0.0D0)) FUNCTION estrms (APARM, CPARM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: APARM + REAL(DOUBLE), INTENT(IN) :: CPARM + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rnucleus90/geniso.f90 b/src/appl/rnucleus90/geniso.f90 index 507e77eca..0c2f9cb34 100644 --- a/src/appl/rnucleus90/geniso.f90 +++ b/src/appl/rnucleus90/geniso.f90 @@ -20,7 +20,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM GENISO + PROGRAM GENISO ! * ! Generates the isotope data file for the GRASP92 suite of codes. * ! * @@ -30,144 +30,144 @@ PROGRAM GENISO ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE CONS_C - USE IOUNIT_C + USE vast_kind_param, ONLY: DOUBLE + USE CONS_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I - USE getcpr_I + USE getyn_I + USE openfl_I + USE getcpr_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, NENEU + INTEGER :: IERR, NENEU REAL(DOUBLE) :: EMEAMU, ALFAI, Z, A, CPARM, APARM, RRMS, TPARM, AMAMU, & - EBIND, EMNAMU, SQN, DMOMNM, QMOMB - LOGICAL :: YES - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + EBIND, EMNAMU, SQN, DMOMNM, QMOMB + LOGICAL :: YES + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! - DATA EMEAMU/ 5.48579903D-04/ - DATA ALFAI/ 137.0359895D00/ + DATA EMEAMU/ 5.48579903D-04/ + DATA ALFAI/ 137.0359895D00/ ! ! File grasp92.iso is FORMATTED ! - DEFNAM = 'isodata' - FORM = 'FORMATTED' - STATUS = 'NEW' + DEFNAM = 'isodata' + FORM = 'FORMATTED' + STATUS = 'NEW' ! - FILNAM = DEFNAM + FILNAM = DEFNAM ! - CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) + CALL OPENFL (22, FILNAM, FORM, STATUS, IERR) ! - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error when opening isodata' - STOP - ENDIF + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error when opening isodata' + STOP + ENDIF ! - WRITE (ISTDE, *) 'Enter the atomic number:' - - READ (5, *) Z - WRITE (22, 300) 'Atomic number:' - WRITE (22, *) Z + WRITE (ISTDE, *) 'Enter the atomic number:' + + READ (5, *) Z + WRITE (22, 300) 'Atomic number:' + WRITE (22, *) Z ! WRITE (ISTDE, *) 'Enter the mass number (0 if the', & - ' nucleus is to be modelled as a point source:' - - READ (5, *) A - - WRITE (22, 300) 'Mass number (integer) :' - WRITE (22, *) A - - IF (A == 0.0D00) THEN - - CPARM = 0.0D00 - APARM = 0.0D00 - ELSE - RRMS = 0.836D00*A**(1.0D00/3.0D00) + 0.570D00 + ' nucleus is to be modelled as a point source:' + + READ (5, *) A + + WRITE (22, 300) 'Mass number (integer) :' + WRITE (22, *) A + + IF (A == 0.0D00) THEN + + CPARM = 0.0D00 + APARM = 0.0D00 + ELSE + RRMS = 0.836D00*A**(1.0D00/3.0D00) + 0.570D00 WRITE (ISTDE, *) 'The default root mean squared', ' radius is ', RRMS& - , ' fm;' - TPARM = 2.30D00 + , ' fm;' + TPARM = 2.30D00 WRITE (ISTDE, *) ' the default nuclear skin thickness', ' is ', TPARM& - , ' fm;' - WRITE (ISTDE, *) 'Revise these values?' - YES = GETYN() - IF (YES) THEN + , ' fm;' + WRITE (ISTDE, *) 'Revise these values?' + YES = GETYN() + IF (YES) THEN WRITE (ISTDE, *) 'Enter the root mean squared', & - ' radius of the nucleus (in fm):' - READ (5, *) RRMS + ' radius of the nucleus (in fm):' + READ (5, *) RRMS WRITE (ISTDE, *) 'Enter the skin thickness of', & - ' the nucleus (in fm):' - READ (5, *) TPARM - ENDIF - APARM = TPARM/(4.0D00*LOG(3.0D00)) - CALL GETCPR (RRMS, APARM, CPARM) - ENDIF - WRITE (22, 300) 'Fermi distribution parameter a:' - WRITE (22, *) APARM - WRITE (22, 300) 'Fermi distribution parameter c:' - WRITE (22, *) CPARM + ' the nucleus (in fm):' + READ (5, *) TPARM + ENDIF + APARM = TPARM/(4.0D00*LOG(3.0D00)) + CALL GETCPR (RRMS, APARM, CPARM) + ENDIF + WRITE (22, 300) 'Fermi distribution parameter a:' + WRITE (22, *) APARM + WRITE (22, 300) 'Fermi distribution parameter c:' + WRITE (22, *) CPARM ! WRITE (ISTDE, *) 'Enter the mass of the neutral', & - ' atom (in amu) (0 if the nucleus is to be static):' - READ (5, *) AMAMU - IF (AMAMU /= 0.0D00) THEN + ' atom (in amu) (0 if the nucleus is to be static):' + READ (5, *) AMAMU + IF (AMAMU /= 0.0D00) THEN ! WRITE (ISTDE, *) 'Enter your best estimate of the ground', & -! ' state energy of, the neutral atom (in Hartrees):' -! READ (5, *) EBIND - +! ' state energy of, the neutral atom (in Hartrees):' +! READ (5, *) EBIND + !XHH better use NINT, not INT. ! NENEU = INT (Z) - NENEU = NINT(Z) + NENEU = NINT(Z) EBIND = 0.D0 - + ! WRITE (ISTDE, *) 'The number of electrons in the', & -! ' neutral atom is deduced to be', NENEU, ';' -! WRITE (ISTDE, *) 'Revise this?' -! YES = GETYN() -! IF (YES) THEN +! ' neutral atom is deduced to be', NENEU, ';' +! WRITE (ISTDE, *) 'Revise this?' +! YES = GETYN() +! IF (YES) THEN ! WRITE (ISTDE, *) 'Enter the number of electrons', & -! ' in the neutral atom:' -! READ (5, *) NENEU -! ENDIF -! IF (EBIND > 0.0D00) EBIND = -EBIND - EMNAMU = AMAMU - EMEAMU*DBLE(NENEU) - EMEAMU*EBIND/ALFAI**2 - ELSE - EMNAMU = 0.0D00 - ENDIF -! - WRITE (22, 300) 'Mass of nucleus (in amu):' - WRITE (22, *) EMNAMU +! ' in the neutral atom:' +! READ (5, *) NENEU +! ENDIF +! IF (EBIND > 0.0D00) EBIND = -EBIND + EMNAMU = AMAMU - EMEAMU*DBLE(NENEU) - EMEAMU*EBIND/ALFAI**2 + ELSE + EMNAMU = 0.0D00 + ENDIF +! + WRITE (22, 300) 'Mass of nucleus (in amu):' + WRITE (22, *) EMNAMU ! WRITE (ISTDE, *) 'Enter the nuclear spin quantum', & - ' number (I) (in units of h / 2 pi):' - READ (5, *) SQN - WRITE (22, 300) 'Nuclear spin (I) (in units of h / 2 pi):' - WRITE (22, *) SQN + ' number (I) (in units of h / 2 pi):' + READ (5, *) SQN + WRITE (22, 300) 'Nuclear spin (I) (in units of h / 2 pi):' + WRITE (22, *) SQN ! WRITE (ISTDE, *) 'Enter the nuclear dipole moment', & - ' (in nuclear magnetons):' - READ (5, *) DMOMNM - WRITE (22, 300) 'Nuclear dipole moment (in nuclear magnetons):' - WRITE (22, *) DMOMNM + ' (in nuclear magnetons):' + READ (5, *) DMOMNM + WRITE (22, 300) 'Nuclear dipole moment (in nuclear magnetons):' + WRITE (22, *) DMOMNM ! - WRITE (ISTDE, *) 'Enter the nuclear quadrupole', ' moment (in barns):' - READ (5, *) QMOMB - WRITE (22, 300) 'Nuclear quadrupole moment (in barns):' - WRITE (22, *) QMOMB + WRITE (ISTDE, *) 'Enter the nuclear quadrupole', ' moment (in barns):' + READ (5, *) QMOMB + WRITE (22, 300) 'Nuclear quadrupole moment (in barns):' + WRITE (22, *) QMOMB ! - CLOSE(22) + CLOSE(22) ! - STOP + STOP ! - 300 FORMAT(A) - STOP + 300 FORMAT(A) + STOP ! - END PROGRAM GENISO + END PROGRAM GENISO diff --git a/src/appl/rnucleus90/getcpr.f90 b/src/appl/rnucleus90/getcpr.f90 index b71fa269a..48e922c11 100644 --- a/src/appl/rnucleus90/getcpr.f90 +++ b/src/appl/rnucleus90/getcpr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETCPR(RRMS, APARM, CPARM) + SUBROUTINE GETCPR(RRMS, APARM, CPARM) ! * ! Determines the parameter `c' (CPARM) for a Fermi nucleus, given * ! the root mean square radius (RRMS) and the parameter `a' (APARM). * @@ -14,77 +14,77 @@ SUBROUTINE GETCPR(RRMS, APARM, CPARM) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE estrms_I + USE estrms_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: RRMS - REAL(DOUBLE) :: APARM - REAL(DOUBLE) , INTENT(OUT) :: CPARM + REAL(DOUBLE) , INTENT(IN) :: RRMS + REAL(DOUBLE) :: APARM + REAL(DOUBLE) , INTENT(OUT) :: CPARM !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: ACCY, CPMIN, CPMAX, CPTRY, RMSTRY + REAL(DOUBLE) :: ACCY, CPMIN, CPMAX, CPTRY, RMSTRY !----------------------------------------------- ! !xhb !xh Accuracy parameter !xhe - ACCY = 1.0D-12 + ACCY = 1.0D-12 ! ! Bracket CPARM with a lower and upper limit ! ! Lower limit ! - CPMIN = RRMS - CPMIN = 0.5D00*CPMIN - DO WHILE(ESTRMS(APARM,CPMIN) > RRMS) - CPMIN = 0.5D00*CPMIN - END DO + CPMIN = RRMS + CPMIN = 0.5D00*CPMIN + DO WHILE(ESTRMS(APARM,CPMIN) > RRMS) + CPMIN = 0.5D00*CPMIN + END DO ! ! Upper limit ! - CPMAX = RRMS - CPMAX = 2.0D00*CPMAX - DO WHILE(ESTRMS(APARM,CPMAX) < RRMS) - CPMAX = 2.0D00*CPMAX - END DO + CPMAX = RRMS + CPMAX = 2.0D00*CPMAX + DO WHILE(ESTRMS(APARM,CPMAX) < RRMS) + CPMAX = 2.0D00*CPMAX + END DO ! ! Find CPARM by the method of bisection ! - CPTRY = 0.5D00*(CPMAX + CPMIN) + CPTRY = 0.5D00*(CPMAX + CPMIN) ! - RMSTRY = ESTRMS(APARM,CPTRY) + RMSTRY = ESTRMS(APARM,CPTRY) ! - IF (RMSTRY > RRMS) THEN - CPMAX = CPTRY - ELSE - CPMIN = CPTRY - ENDIF + IF (RMSTRY > RRMS) THEN + CPMAX = CPTRY + ELSE + CPMIN = CPTRY + ENDIF DO WHILE((CPMAX - CPMIN)/(CPMAX + CPMIN)>ACCY .AND. ABS(RMSTRY-RRMS)/RRMS& - >ACCY) - CPTRY = 0.5D00*(CPMAX + CPMIN) + >ACCY) + CPTRY = 0.5D00*(CPMAX + CPMIN) ! - RMSTRY = ESTRMS(APARM,CPTRY) + RMSTRY = ESTRMS(APARM,CPTRY) ! - IF (RMSTRY > RRMS) THEN - CPMAX = CPTRY - ELSE - CPMIN = CPTRY - ENDIF + IF (RMSTRY > RRMS) THEN + CPMAX = CPTRY + ELSE + CPMIN = CPTRY + ENDIF ! - END DO + END DO ! - CPARM = CPTRY + CPARM = CPTRY ! - RETURN - END SUBROUTINE GETCPR + RETURN + END SUBROUTINE GETCPR diff --git a/src/appl/rnucleus90/getcpr_I.f90 b/src/appl/rnucleus90/getcpr_I.f90 index fabace552..6aaeaf3c4 100644 --- a/src/appl/rnucleus90/getcpr_I.f90 +++ b/src/appl/rnucleus90/getcpr_I.f90 @@ -1,11 +1,11 @@ - MODULE getcpr_I + MODULE getcpr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 - SUBROUTINE getcpr (RRMS, APARM, CPARM) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: RRMS - REAL(DOUBLE) :: APARM - REAL(DOUBLE), INTENT(OUT) :: CPARM - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 + SUBROUTINE getcpr (RRMS, APARM, CPARM) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: RRMS + REAL(DOUBLE) :: APARM + REAL(DOUBLE), INTENT(OUT) :: CPARM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rnucleus90/isodata b/src/appl/rnucleus90/isodata index 3bb5fe3f7..cc45fbfea 100644 --- a/src/appl/rnucleus90/isodata +++ b/src/appl/rnucleus90/isodata @@ -1,10 +1,10 @@ Atomic number: - 10.000000000000000 + 10.000000000000000 Mass number (integer) : - 20.000000000000000 + 20.000000000000000 Fermi distribution parameter a: - 0.52338755531043146 + 0.52338755531043146 Fermi distribution parameter c: - 2.6699669452267911 + 2.6699669452267911 Mass of nucleus (in amu): - 19.994514493096268 + 19.994514493096268 diff --git a/src/appl/rnucleus90/skfun.f90 b/src/appl/rnucleus90/skfun.f90 index 91c1a008b..abf922711 100644 --- a/src/appl/rnucleus90/skfun.f90 +++ b/src/appl/rnucleus90/skfun.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION SKFUN (K, X) + REAL(KIND(0.0D0)) FUNCTION SKFUN (K, X) ! * ! Computes the function * ! n nx * @@ -19,45 +19,45 @@ REAL(KIND(0.0D0)) FUNCTION SKFUN (K, X) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:31:28 1/ 3/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: K - REAL(DOUBLE) , INTENT(IN) :: X + INTEGER , INTENT(IN) :: K + REAL(DOUBLE) , INTENT(IN) :: X !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: QUASIZERO = 1.D-15 + REAL(DOUBLE), PARAMETER :: QUASIZERO = 1.D-15 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: DNUMER, EN, BASE, DELTA + REAL(DOUBLE) :: DNUMER, EN, BASE, DELTA !----------------------------------------------- !xhe - - DNUMER = 1.0D00 - EN = 0.0D00 - BASE = -EXP(X) - SKFUN = 0.0D00 - DNUMER = DNUMER*BASE - EN = EN + 1.0D00 - DELTA = DNUMER/EN**K - SKFUN = SKFUN + DELTA - DO WHILE(ABS(DELTA/SKFUN) > QUASIZERO) - DNUMER = DNUMER*BASE - EN = EN + 1.0D00 - DELTA = DNUMER/EN**K - SKFUN = SKFUN + DELTA + + DNUMER = 1.0D00 + EN = 0.0D00 + BASE = -EXP(X) + SKFUN = 0.0D00 + DNUMER = DNUMER*BASE + EN = EN + 1.0D00 + DELTA = DNUMER/EN**K + SKFUN = SKFUN + DELTA + DO WHILE(ABS(DELTA/SKFUN) > QUASIZERO) + DNUMER = DNUMER*BASE + EN = EN + 1.0D00 + DELTA = DNUMER/EN**K + SKFUN = SKFUN + DELTA !xhb !xh IF (ABS (DELTA/SKFUN) .GT. 1.0D-15 ) GOTO 1 - END DO + END DO !xhe ! - RETURN - END FUNCTION SKFUN + RETURN + END FUNCTION SKFUN diff --git a/src/appl/rnucleus90/skfun_I.f90 b/src/appl/rnucleus90/skfun_I.f90 index 4eaa43def..ccaaca90f 100644 --- a/src/appl/rnucleus90/skfun_I.f90 +++ b/src/appl/rnucleus90/skfun_I.f90 @@ -1,10 +1,10 @@ - MODULE skfun_I + MODULE skfun_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 - REAL(KIND(0.0D0)) FUNCTION skfun (K, X) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(IN) :: X - END FUNCTION - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 + REAL(KIND(0.0D0)) FUNCTION skfun (K, X) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(IN) :: X + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/Makefile b/src/appl/rtransition90/Makefile old mode 100755 new mode 100644 index 1065e5528..463c47981 --- a/src/appl/rtransition90/Makefile +++ b/src/appl/rtransition90/Makefile @@ -34,7 +34,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -o $@ @@ -44,4 +44,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rtransition90/alclla.f90 b/src/appl/rtransition90/alclla.f90 index 5a14d971b..738079052 100644 --- a/src/appl/rtransition90/alclla.f90 +++ b/src/appl/rtransition90/alclla.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, IMODE) + LLDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -12,8 +12,8 @@ SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -23,68 +23,68 @@ SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: LLDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: LLDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IBEG, ILAB, ILAST, ILEFT, & IPTCSF, IRIGHT, LBLINT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - LLDIM = 64 + LLDIM = 64 ! ! Allocate storage for arrays ! - CALL ALLOC (IBEG, LLDIM, 'IBEG', 'ALCLLA') - CALL ALLOC (ILAB, LLDIM, 'ILAB', 'ALCLLA') - CALL ALLOC (ILAST, LLDIM, 'ILAST', 'ALCLLA') - CALL ALLOC (ILEFT, LLDIM, 'ILEFT', 'ALCLLA') - CALL ALLOC (IPTCSF, LLDIM, 'IPTCSF', 'ALCLLA') - CALL ALLOC (IRIGHT, LLDIM, 'IRIGHT', 'ALCLLA') - CALL ALLOC (LBLINT, LLDIM, 'LBLINT', 'ALCLLA') + CALL ALLOC (IBEG, LLDIM, 'IBEG', 'ALCLLA') + CALL ALLOC (ILAB, LLDIM, 'ILAB', 'ALCLLA') + CALL ALLOC (ILAST, LLDIM, 'ILAST', 'ALCLLA') + CALL ALLOC (ILEFT, LLDIM, 'ILEFT', 'ALCLLA') + CALL ALLOC (IPTCSF, LLDIM, 'IPTCSF', 'ALCLLA') + CALL ALLOC (IRIGHT, LLDIM, 'IRIGHT', 'ALCLLA') + CALL ALLOC (LBLINT, LLDIM, 'LBLINT', 'ALCLLA') ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*LLDIM + NEWSIZ = 2*LLDIM ! - CALL RALLOC (IBEG, NEWSIZ, 'IBEG', 'ALCLLA') - CALL RALLOC (ILAB, NEWSIZ, 'ILAB', 'ALCLLA') - CALL RALLOC (ILAST, NEWSIZ, 'ILAST', 'ALCLLA') - CALL RALLOC (ILEFT, NEWSIZ, 'ILEFT', 'ALCLLA') - CALL RALLOC (IPTCSF, NEWSIZ, 'IPTCSF', 'ALCLLA') - CALL RALLOC (IRIGHT, NEWSIZ, 'IRIGHT', 'ALCLLA') - CALL RALLOC (LBLINT, NEWSIZ, 'LBLINT', 'ALCLLA') + CALL RALLOC (IBEG, NEWSIZ, 'IBEG', 'ALCLLA') + CALL RALLOC (ILAB, NEWSIZ, 'ILAB', 'ALCLLA') + CALL RALLOC (ILAST, NEWSIZ, 'ILAST', 'ALCLLA') + CALL RALLOC (ILEFT, NEWSIZ, 'ILEFT', 'ALCLLA') + CALL RALLOC (IPTCSF, NEWSIZ, 'IPTCSF', 'ALCLLA') + CALL RALLOC (IRIGHT, NEWSIZ, 'IRIGHT', 'ALCLLA') + CALL RALLOC (LBLINT, NEWSIZ, 'LBLINT', 'ALCLLA') ! - LLDIM = NEWSIZ + LLDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (IBEG, 'IBEG', 'ALCLLA') - CALL DALLOC (ILAB, 'ILAB', 'ALCLLA') - CALL DALLOC (ILAST, 'ILAST', 'ALCLLA') - CALL DALLOC (ILEFT, 'ILEFT', 'ALCLLA') - CALL DALLOC (IPTCSF, 'IPTCSF', 'ALCLLA') - CALL DALLOC (IRIGHT, 'IRIGHT', 'ALCLLA') - CALL DALLOC (LBLINT, 'LBLINT', 'ALCLLA') + CALL DALLOC (IBEG, 'IBEG', 'ALCLLA') + CALL DALLOC (ILAB, 'ILAB', 'ALCLLA') + CALL DALLOC (ILAST, 'ILAST', 'ALCLLA') + CALL DALLOC (ILEFT, 'ILEFT', 'ALCLLA') + CALL DALLOC (IPTCSF, 'IPTCSF', 'ALCLLA') + CALL DALLOC (IRIGHT, 'IRIGHT', 'ALCLLA') + CALL DALLOC (LBLINT, 'LBLINT', 'ALCLLA') ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCLLA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCLLA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCLLA + RETURN + END SUBROUTINE ALCLLA diff --git a/src/appl/rtransition90/alclla_I.f90 b/src/appl/rtransition90/alclla_I.f90 index 037098a5b..40cb5fe53 100644 --- a/src/appl/rtransition90/alclla_I.f90 +++ b/src/appl/rtransition90/alclla_I.f90 @@ -1,15 +1,15 @@ - MODULE alclla_I + MODULE alclla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCS, IRIGH, LBLIN, & LLDIM, IMODE) - INTEGER, INTENT(INOUT) :: LLDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: LLDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IBEG, ILAB, ILAST, ILEFT, & IPTCS, IRIGH, LBLIN !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/alcnma.f90 b/src/appl/rtransition90/alcnma.f90 index 69813f9bb..adb4c90a2 100644 --- a/src/appl/rtransition90/alcnma.f90 +++ b/src/appl/rtransition90/alcnma.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) + SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -11,8 +11,8 @@ SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -22,58 +22,58 @@ SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NMDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: NMDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IPTR, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NMDIM = 64 + NMDIM = 64 ! ! Allocate storage for arrays ! - CALL ALLOC (IPTR, NMDIM, 'IPTR', 'ALCNMA') - CALL ALLOC (ISLDR, NMDIM, 'ISLDR', 'ALCNMA') - CALL ALLOC (ISLDR1, NMDIM, 'ISLDR1', 'ALCNMA') - CALL ALLOC (XSLDR, NMDIM, 'XSLDR', 'ALCNMA') + CALL ALLOC (IPTR, NMDIM, 'IPTR', 'ALCNMA') + CALL ALLOC (ISLDR, NMDIM, 'ISLDR', 'ALCNMA') + CALL ALLOC (ISLDR1, NMDIM, 'ISLDR1', 'ALCNMA') + CALL ALLOC (XSLDR, NMDIM, 'XSLDR', 'ALCNMA') ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NMDIM + NEWSIZ = 2*NMDIM ! - CALL RALLOC (IPTR, NEWSIZ, 'IPTR', 'ALCNMA') - CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNMA') - CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNMA') - CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNMA') + CALL RALLOC (IPTR, NEWSIZ, 'IPTR', 'ALCNMA') + CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNMA') + CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNMA') + CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNMA') ! - NMDIM = NEWSIZ + NMDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (IPTR, 'IPTR', 'ALCNMA') - CALL DALLOC (ISLDR, 'ISLDR', 'ALCNMA') - CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNMA') - CALL DALLOC (XSLDR, 'XSLDR', 'ALCNMA') + CALL DALLOC (IPTR, 'IPTR', 'ALCNMA') + CALL DALLOC (ISLDR, 'ISLDR', 'ALCNMA') + CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNMA') + CALL DALLOC (XSLDR, 'XSLDR', 'ALCNMA') ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNMA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNMA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNMA + RETURN + END SUBROUTINE ALCNMA diff --git a/src/appl/rtransition90/alcnma_I.f90 b/src/appl/rtransition90/alcnma_I.f90 index ef1bcb634..ca169fdb2 100644 --- a/src/appl/rtransition90/alcnma_I.f90 +++ b/src/appl/rtransition90/alcnma_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnma_I + MODULE alcnma_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE INTEGER, DIMENSION(:), pointer :: IPTR, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR - INTEGER, INTENT(INOUT) :: NMDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: NMDIM + INTEGER, INTENT(IN) :: IMODE !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/alcnsa.f90 b/src/appl/rtransition90/alcnsa.f90 index 1add68ac2..84454dbb5 100644 --- a/src/appl/rtransition90/alcnsa.f90 +++ b/src/appl/rtransition90/alcnsa.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, IMODE) + HM2, LAB, NPTR, NSDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -12,8 +12,8 @@ SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & ! Farid A. Parpia. Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -23,76 +23,76 @@ SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NSDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: NSDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: JJA, JJB, LAB, NPTR REAL(DOUBLE), DIMENSION(:), POINTER :: HB1, HB2, HC1, HC2, HM1, HM2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NSDIM = 1 + NSDIM = 1 ! ! Allocate storage for arrays ! - CALL ALLOC (JJA, NSDIM, 'JJA', 'ALCNSA') - CALL ALLOC (JJB, NSDIM, 'JJB', 'ALCNSA' ) - CALL ALLOC (HB1, NSDIM, 'HB1', 'ALCNSA') - CALL ALLOC (HB2, NSDIM, 'HB2', 'ALCNSA') - CALL ALLOC (HC1, NSDIM, 'HC1', 'ALCNSA') - CALL ALLOC (HC2, NSDIM, 'HC2', 'ALCNSA') - CALL ALLOC (HM1, NSDIM, 'HM1', 'ALCNSA') - CALL ALLOC (HM2, NSDIM, 'HM2', 'ALCNSA') - CALL ALLOC (LAB, NSDIM, 'LAB', 'ALCNSA' ) - CALL ALLOC (NPTR, NSDIM, 'NPTR', 'ALCNSA' ) + CALL ALLOC (JJA, NSDIM, 'JJA', 'ALCNSA') + CALL ALLOC (JJB, NSDIM, 'JJB', 'ALCNSA' ) + CALL ALLOC (HB1, NSDIM, 'HB1', 'ALCNSA') + CALL ALLOC (HB2, NSDIM, 'HB2', 'ALCNSA') + CALL ALLOC (HC1, NSDIM, 'HC1', 'ALCNSA') + CALL ALLOC (HC2, NSDIM, 'HC2', 'ALCNSA') + CALL ALLOC (HM1, NSDIM, 'HM1', 'ALCNSA') + CALL ALLOC (HM2, NSDIM, 'HM2', 'ALCNSA') + CALL ALLOC (LAB, NSDIM, 'LAB', 'ALCNSA' ) + CALL ALLOC (NPTR, NSDIM, 'NPTR', 'ALCNSA' ) ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NSDIM + NEWSIZ = 2*NSDIM ! - CALL RALLOC (JJA, NEWSIZ, 'JJA', 'ALCNSA') - CALL RALLOC (JJB, NEWSIZ, 'JJB', 'ALCNSA' ) - CALL RALLOC (HB1, NEWSIZ, 'HB1', 'ALCNSA') - CALL RALLOC (HB2, NEWSIZ, 'HB2', 'ALCNSA') - CALL RALLOC (HC1, NEWSIZ, 'HC1', 'ALCNSA') - CALL RALLOC (HC2, NEWSIZ, 'HC2', 'ALCNSA') - CALL RALLOC (HM1, NEWSIZ, 'HM1', 'ALCNSA') - CALL RALLOC (HM2, NEWSIZ, 'HM2', 'ALCNSA') - CALL RALLOC (LAB, NEWSIZ, 'LAB', 'ALCNSA' ) - CALL RALLOC (NPTR, NEWSIZ, 'NPTR', 'ALCNSA' ) + CALL RALLOC (JJA, NEWSIZ, 'JJA', 'ALCNSA') + CALL RALLOC (JJB, NEWSIZ, 'JJB', 'ALCNSA' ) + CALL RALLOC (HB1, NEWSIZ, 'HB1', 'ALCNSA') + CALL RALLOC (HB2, NEWSIZ, 'HB2', 'ALCNSA') + CALL RALLOC (HC1, NEWSIZ, 'HC1', 'ALCNSA') + CALL RALLOC (HC2, NEWSIZ, 'HC2', 'ALCNSA') + CALL RALLOC (HM1, NEWSIZ, 'HM1', 'ALCNSA') + CALL RALLOC (HM2, NEWSIZ, 'HM2', 'ALCNSA') + CALL RALLOC (LAB, NEWSIZ, 'LAB', 'ALCNSA' ) + CALL RALLOC (NPTR, NEWSIZ, 'NPTR', 'ALCNSA' ) ! - NSDIM = NEWSIZ + NSDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (JJA, 'JJA', 'ALCNSA') - CALL DALLOC (JJB, 'JJB', 'ALCNSA' ) - CALL DALLOC (HB1, 'HB1', 'ALCNSA') - CALL DALLOC (HB2, 'HB2', 'ALCNSA') - CALL DALLOC (HC1, 'HC1', 'ALCNSA') - CALL DALLOC (HC2, 'HC2', 'ALCNSA') - CALL DALLOC (HM1, 'HM1', 'ALCNSA') - CALL DALLOC (HM2, 'HM2', 'ALCNSA') - CALL DALLOC (LAB, 'LAB', 'ALCNSA' ) - CALL DALLOC (NPTR, 'NPTR', 'ALCNSA' ) + CALL DALLOC (JJA, 'JJA', 'ALCNSA') + CALL DALLOC (JJB, 'JJB', 'ALCNSA' ) + CALL DALLOC (HB1, 'HB1', 'ALCNSA') + CALL DALLOC (HB2, 'HB2', 'ALCNSA') + CALL DALLOC (HC1, 'HC1', 'ALCNSA') + CALL DALLOC (HC2, 'HC2', 'ALCNSA') + CALL DALLOC (HM1, 'HM1', 'ALCNSA') + CALL DALLOC (HM2, 'HM2', 'ALCNSA') + CALL DALLOC (LAB, 'LAB', 'ALCNSA' ) + CALL DALLOC (NPTR, 'NPTR', 'ALCNSA' ) ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNSA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNSA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNSA + RETURN + END SUBROUTINE ALCNSA diff --git a/src/appl/rtransition90/alcnsa_I.f90 b/src/appl/rtransition90/alcnsa_I.f90 index a0c23962c..a45a0cb39 100644 --- a/src/appl/rtransition90/alcnsa_I.f90 +++ b/src/appl/rtransition90/alcnsa_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnsa_I + MODULE alcnsa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, IMODE) + HM2, LAB, NPTR, NSDIM, IMODE) USE vast_kind_param, ONLY: DOUBLE - INTEGER :: NSDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER :: NSDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: JJA, JJB, LAB, NPTR REAL(DOUBLE), DIMENSION(:), POINTER :: HB1, HB2, HC1, HC2, HM1, HM2 - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/alcnta.f90 b/src/appl/rtransition90/alcnta.f90 index 156c1886c..9db643a1a 100644 --- a/src/appl/rtransition90/alcnta.f90 +++ b/src/appl/rtransition90/alcnta.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) + SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -11,8 +11,8 @@ SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) ! Farid A. Parpia. Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -22,55 +22,55 @@ SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NTDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER :: NTDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), POINTER :: ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), POINTER :: XSLDR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NTDIM = 1 + NTDIM = 1 ! ! Allocate storage for arrays ! - CALL ALLOC (ISLDR, NTDIM, 'ISLDR', 'ALCNTA' ) - CALL ALLOC (ISLDR1, NTDIM,'ISLDR1', 'ALCNTA' ) - CALL ALLOC (XSLDR, NTDIM, 'XSLDR', 'ALCNTA' ) + CALL ALLOC (ISLDR, NTDIM, 'ISLDR', 'ALCNTA' ) + CALL ALLOC (ISLDR1, NTDIM,'ISLDR1', 'ALCNTA' ) + CALL ALLOC (XSLDR, NTDIM, 'XSLDR', 'ALCNTA' ) ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NTDIM + NEWSIZ = 2*NTDIM ! - CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNTA' ) - CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNTA' ) - CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNTA' ) + CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNTA' ) + CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNTA' ) + CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNTA' ) ! - NTDIM = NEWSIZ + NTDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (ISLDR, 'ISLDR', 'ALCNTA' ) - CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNTA' ) - CALL DALLOC (XSLDR, 'XSLDR', 'ALCNTA' ) + CALL DALLOC (ISLDR, 'ISLDR', 'ALCNTA' ) + CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNTA' ) + CALL DALLOC (XSLDR, 'XSLDR', 'ALCNTA' ) ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNTA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNTA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNTA + RETURN + END SUBROUTINE ALCNTA diff --git a/src/appl/rtransition90/alcnta_I.f90 b/src/appl/rtransition90/alcnta_I.f90 index fd84a159f..86494d590 100644 --- a/src/appl/rtransition90/alcnta_I.f90 +++ b/src/appl/rtransition90/alcnta_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnta_I + MODULE alcnta_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE INTEGER, DIMENSION(:), POINTER :: ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), POINTER :: XSLDR - INTEGER, INTENT(INOUT) :: NTDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: NTDIM + INTEGER, INTENT(IN) :: IMODE !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/angdata.f90 b/src/appl/rtransition90/angdata.f90 index 256da4bca..1534376fa 100644 --- a/src/appl/rtransition90/angdata.f90 +++ b/src/appl/rtransition90/angdata.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) + SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) ! * ! Checks if the angular file name(1).name(2).T is available * ! and appropriate * @@ -8,13 +8,13 @@ SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) ! Written by Per Jonsson 6 March 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE orb_C, ONLY: NCF, NW, IQA USE osc_C, ONLY: NKP, KP !----------------------------------------------- @@ -24,65 +24,65 @@ SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JKP - INTEGER, INTENT(IN) :: NFILE2 - LOGICAL, INTENT(OUT) :: AVAIL - CHARACTER, INTENT(INOUT) :: NAME(2)*24 + INTEGER :: JKP + INTEGER, INTENT(IN) :: NFILE2 + LOGICAL, INTENT(OUT) :: AVAIL + CHARACTER, INTENT(INOUT) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1, J2, IBLKI, IBLKF, NWD, NKPD - LOGICAL :: FOUND - CHARACTER, DIMENSION(-9:9) :: S*2 + INTEGER :: J1, J2, IBLKI, IBLKF, NWD, NKPD + LOGICAL :: FOUND + CHARACTER, DIMENSION(-9:9) :: S*2 !----------------------------------------------- - - S((-9)) = '-9' - S((-8)) = '-8' - S((-7)) = '-7' - S((-6)) = '-6' - S((-5)) = '-5' - S((-4)) = '-4' - S((-3)) = '-3' - S((-2)) = '-2' - S((-1)) = '-1' - S(0) = '+0' - S(1) = '+1' - S(2) = '+2' - S(3) = '+3' - S(4) = '+4' - S(5) = '+5' - S(6) = '+6' - S(7) = '+7' - S(8) = '+8' - S(9) = '+9' - - J1 = INDEX(NAME(1),' ') - J2 = INDEX(NAME(2),' ') + + S((-9)) = '-9' + S((-8)) = '-8' + S((-7)) = '-7' + S((-6)) = '-6' + S((-5)) = '-5' + S((-4)) = '-4' + S((-3)) = '-3' + S((-2)) = '-2' + S((-1)) = '-1' + S(0) = '+0' + S(1) = '+1' + S(2) = '+2' + S(3) = '+3' + S(4) = '+4' + S(5) = '+5' + S(6) = '+6' + S(7) = '+7' + S(8) = '+8' + S(9) = '+9' + + J1 = INDEX(NAME(1),' ') + J2 = INDEX(NAME(2),' ') INQUIRE(FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(KP(JKP))//'T'& - , EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (6, *) - WRITE (6, *) ' Angular file not available' - AVAIL = .FALSE. - RETURN - ELSE + , EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (6, *) + WRITE (6, *) ' Angular file not available' + AVAIL = .FALSE. + RETURN + ELSE ! ! Open the file and check if it is appropriate for the present case ! OPEN(UNIT=NFILE2, FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(& - KP(JKP))//'T', STATUS='OLD', FORM='UNFORMATTED', POSITION='asis') - REWIND (NFILE2) - READ (NFILE2) IBLKI, IBLKF, NWD, NKPD - IF (.NOT.(NWD==NW .AND. NKPD==NKP)) THEN - WRITE (6, *) ' Angular file not appropriate' - AVAIL = .FALSE. - CLOSE(NFILE2, STATUS='DELETE') - RETURN - ELSE - REWIND (NFILE2) - WRITE (6, *) ' Angular data read from file' - AVAIL = .TRUE. - ENDIF - ENDIF - RETURN - END SUBROUTINE ANGDATA + KP(JKP))//'T', STATUS='OLD', FORM='UNFORMATTED', POSITION='asis') + REWIND (NFILE2) + READ (NFILE2) IBLKI, IBLKF, NWD, NKPD + IF (.NOT.(NWD==NW .AND. NKPD==NKP)) THEN + WRITE (6, *) ' Angular file not appropriate' + AVAIL = .FALSE. + CLOSE(NFILE2, STATUS='DELETE') + RETURN + ELSE + REWIND (NFILE2) + WRITE (6, *) ' Angular data read from file' + AVAIL = .TRUE. + ENDIF + ENDIF + RETURN + END SUBROUTINE ANGDATA diff --git a/src/appl/rtransition90/angdata_I.f90 b/src/appl/rtransition90/angdata_I.f90 index d5d704162..e5fd8946c 100644 --- a/src/appl/rtransition90/angdata_I.f90 +++ b/src/appl/rtransition90/angdata_I.f90 @@ -1,13 +1,13 @@ - MODULE angdata_I + MODULE angdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE angdata (NAME, AVAIL, JKP, NFILE2) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME - LOGICAL, INTENT(OUT) :: AVAIL - INTEGER :: JKP - INTEGER, INTENT(IN) :: NFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE angdata (NAME, AVAIL, JKP, NFILE2) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME + LOGICAL, INTENT(OUT) :: AVAIL + INTEGER :: JKP + INTEGER, INTENT(IN) :: NFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/bessj.f90 b/src/appl/rtransition90/bessj.f90 index ce42f1a2b..eb1d963d6 100644 --- a/src/appl/rtransition90/bessj.f90 +++ b/src/appl/rtransition90/bessj.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BESSJ(W) + SUBROUTINE BESSJ(W) ! * ! This routine evaluates Bessel fuctions J K ( W*R/C ) at the grid * ! points for K=L-1,L,L+1 and stores them in the arrays BJ(..,1), * @@ -10,155 +10,155 @@ SUBROUTINE BESSJ(W) ! Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bess_C, ONLY: BJ, TC, TD USE debug_C, ONLY: LDBPR - USE grid_C + USE grid_C USE osc_C, ONLY: LK, KK, L=>LK USE DEF_C, ONLY: C, CVAC, PI IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(IN) :: W + REAL(DOUBLE), INTENT(IN) :: W !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I1, IW, NN, IEND, IPROD, I, JCHAN, J, ISWAP, MODNN4, & - JJ, JJJ, II - REAL(DOUBLE) :: EPSI, DFN, WR, WA, XBESS1, S1, SSN, SCN, SN, CN, B, SKEEP + JJ, JJJ, II + REAL(DOUBLE) :: EPSI, DFN, WR, WA, XBESS1, S1, SSN, SCN, SN, CN, B, SKEEP !----------------------------------------------- ! ! - EPSI = 1.0D-05 -! - IW = 1 - NN = L - 1 - IF (KK /= 0) THEN - IW = 2 - NN = L - ENDIF - 1 CONTINUE - IEND = 2*NN + 1 - IPROD = 1 - DO I = 1, IEND, 2 - IPROD = IPROD*I - END DO - DFN = IPROD - JCHAN = N - BJ(1,IW) = 1.0D00 - DO J = 2, N - WR = W*R(J) - WA = -WR*WR*0.5D00 - XBESS1 = 1.0D00 - S1 = 1.0D00 - DO I = 1, 4 - XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) - S1 = S1 + XBESS1 - IF (ABS(XBESS1) < ABS(S1)*EPSI) GO TO 4 - END DO - JCHAN = J - EXIT - 4 CONTINUE - BJ(J,IW) = S1*WR**NN/DFN - END DO + EPSI = 1.0D-05 +! + IW = 1 + NN = L - 1 + IF (KK /= 0) THEN + IW = 2 + NN = L + ENDIF + 1 CONTINUE + IEND = 2*NN + 1 + IPROD = 1 + DO I = 1, IEND, 2 + IPROD = IPROD*I + END DO + DFN = IPROD + JCHAN = N + BJ(1,IW) = 1.0D00 + DO J = 2, N + WR = W*R(J) + WA = -WR*WR*0.5D00 + XBESS1 = 1.0D00 + S1 = 1.0D00 + DO I = 1, 4 + XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) + S1 = S1 + XBESS1 + IF (ABS(XBESS1) < ABS(S1)*EPSI) GO TO 4 + END DO + JCHAN = J + EXIT + 4 CONTINUE + BJ(J,IW) = S1*WR**NN/DFN + END DO ! ! Use sin/cos expansion when power series takes longer ! than 4 terms to converge ! - IF (JCHAN < N) THEN - ISWAP = 0 - MODNN4 = MOD(NN - 1,4) + 1 - SELECT CASE (MODNN4) + IF (JCHAN < N) THEN + ISWAP = 0 + MODNN4 = MOD(NN - 1,4) + 1 + SELECT CASE (MODNN4) ! ! NN = 1, 5, 9, ... ! - CASE DEFAULT - SSN = -1.0D00 - SCN = 1.0D00 - ISWAP = 1 + CASE DEFAULT + SSN = -1.0D00 + SCN = 1.0D00 + ISWAP = 1 ! ! N = 2, 6, 10,.... ! - CASE (2) - SSN = -1.0D00 - SCN = -1.0D00 + CASE (2) + SSN = -1.0D00 + SCN = -1.0D00 ! ! NN = 3, 7, 11,... ! - CASE (3) - SSN = 1.0D00 - SCN = -1.0D00 - ISWAP = 1 + CASE (3) + SSN = 1.0D00 + SCN = -1.0D00 + ISWAP = 1 ! ! NN = 0, 4, 8,... ! - CASE (4) - SSN = 1.0D00 - SCN = 1.0D00 - END SELECT -! - 13 CONTINUE - DO J = JCHAN, N - WA = W*R(J) - IF (ISWAP <= 0) THEN - SN = SSN*SIN(WA) - CN = SCN*COS(WA) - ELSE - SN = SSN*COS(WA) - CN = SCN*SIN(WA) - ENDIF - I = -1 - S1 = 0.0D00 - I = I + 1 - I1 = I - DO I = I1, NN - IF (I == 0) THEN - B = 1.0D00/WA - ELSE - B = B*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I)/WA - ENDIF - S1 = S1 + B*SN - SKEEP = SN - SN = CN - CN = -SKEEP - END DO - BJ(J,IW) = S1 - END DO - ENDIF - IF (NN>=L + 1 .OR. KK==1) THEN + CASE (4) + SSN = 1.0D00 + SCN = 1.0D00 + END SELECT +! + 13 CONTINUE + DO J = JCHAN, N + WA = W*R(J) + IF (ISWAP <= 0) THEN + SN = SSN*SIN(WA) + CN = SCN*COS(WA) + ELSE + SN = SSN*COS(WA) + CN = SCN*SIN(WA) + ENDIF + I = -1 + S1 = 0.0D00 + I = I + 1 + I1 = I + DO I = I1, NN + IF (I == 0) THEN + B = 1.0D00/WA + ELSE + B = B*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I)/WA + ENDIF + S1 = S1 + B*SN + SKEEP = SN + SN = CN + CN = -SKEEP + END DO + BJ(J,IW) = S1 + END DO + ENDIF + IF (NN>=L + 1 .OR. KK==1) THEN ! ! Print out Bessel functions if (debug) option set ! - IF (LDBPR(16)) THEN - DO JJ = 1, 3 - JJJ = L - 2 + JJ - WRITE (99, 300) JJJ, (BJ(II,JJ),II=1,N) - END DO - ENDIF + IF (LDBPR(16)) THEN + DO JJ = 1, 3 + JJJ = L - 2 + JJ + WRITE (99, 300) JJJ, (BJ(II,JJ),II=1,N) + END DO + ENDIF ! ! All done ! ! zou - DO JJ = 1, 3 - JJJ = L - 2 + JJ - BJ(:N,JJ) = BJ(:N,JJ)*(C/CVAC)**JJJ - END DO + DO JJ = 1, 3 + JJJ = L - 2 + JJ + BJ(:N,JJ) = BJ(:N,JJ)*(C/CVAC)**JJJ + END DO ! zou - RETURN - ELSE - NN = NN + 1 - IW = IW + 1 - GO TO 1 - ENDIF + RETURN + ELSE + NN = NN + 1 + IW = IW + 1 + GO TO 1 + ENDIF ! - 300 FORMAT(/,' Bessel function of order ',I3,/(1P,7D18.10)) - RETURN + 300 FORMAT(/,' Bessel function of order ',I3,/(1P,7D18.10)) + RETURN ! - END SUBROUTINE BESSJ + END SUBROUTINE BESSJ diff --git a/src/appl/rtransition90/bessj_I.f90 b/src/appl/rtransition90/bessj_I.f90 index f5446edcf..b54d45634 100644 --- a/src/appl/rtransition90/bessj_I.f90 +++ b/src/appl/rtransition90/bessj_I.f90 @@ -1,11 +1,11 @@ - MODULE bessj_I + MODULE bessj_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bessj (W) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: W - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bessj (W) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: W + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/bioscl.f90 b/src/appl/rtransition90/bioscl.f90 index bacca781f..65d530bb9 100644 --- a/src/appl/rtransition90/bioscl.f90 +++ b/src/appl/rtransition90/bioscl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - PROGRAM BIOSCL + PROGRAM BIOSCL ! * ! This program calculates the transition parameters for a * ! transition between an initial and a final state * @@ -16,41 +16,41 @@ PROGRAM BIOSCL ! and for reducing usage of CPU memory. NIST, October 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE default_C USE debug_C, ONLY: LDBPR, CUTOFF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setmc_I - USE setcon_I - USE fname_I - USE mrgcsl_I - USE setcslm_I - USE getosd_I - USE strsum_I - USE factt_I - USE oscl_I + USE getyn_I + USE setmc_I + USE setcon_I + USE fname_I + USE mrgcsl_I + USE setcslm_I + USE getosd_I + USE strsum_I + USE factt_I + USE oscl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NTEST, NCOUNT1, ILBL - LOGICAL :: YES + LOGICAL :: YES CHARACTER, DIMENSION(2) :: NAME*24 CHARACTER(LEN=128) :: ISOFILE !----------------------------------------------- ! ISOFILE = 'isodata' - NTEST = 1001 - CALL STARTTIME (ncount1, 'RTRANSITION') + NTEST = 1001 + CALL STARTTIME (ncount1, 'RTRANSITION') write(*,*) write(*,*) 'RTRANSITION' write(*,*) 'This program computes transition parameters from' @@ -67,64 +67,64 @@ PROGRAM BIOSCL - WRITE (6, *) - WRITE (6, *) ' Default settings?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDEF = 0 - NDUMP = 1 - ELSE - NDEF = 1 - WRITE (6, *) ' Dump angular data to file?' - YES = GETYN() - IF (YES) THEN - NDUMP = 1 - ELSE - NDUMP = 0 - ENDIF - ENDIF - WRITE (6, *) - WRITE (6, *) ' Input from a CI calculation?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - INPCI = 0 - ELSE - INPCI = 1 - ENDIF + WRITE (6, *) + WRITE (6, *) ' Default settings?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDEF = 0 + NDUMP = 1 + ELSE + NDEF = 1 + WRITE (6, *) ' Dump angular data to file?' + YES = GETYN() + IF (YES) THEN + NDUMP = 1 + ELSE + NDUMP = 0 + ENDIF + ENDIF + WRITE (6, *) + WRITE (6, *) ' Input from a CI calculation?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + INPCI = 0 + ELSE + INPCI = 1 + ENDIF !Rasa -- start - LDBPR = .FALSE. -! WRITE (6, *) ' Generate debug output?' -! YES = GETYN() -! WRITE (6, *) -! IF (YES) THEN -! LDBPR(18) = .TRUE. -! WRITE (6, *) ' Enter the cutoff' -! READ (5, *) CUTOFF -! ENDIF + LDBPR = .FALSE. +! WRITE (6, *) ' Generate debug output?' +! YES = GETYN() +! WRITE (6, *) +! IF (YES) THEN +! LDBPR(18) = .TRUE. +! WRITE (6, *) ' Enter the cutoff' +! READ (5, *) CUTOFF +! ENDIF !Rasa -- end ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Obtain the names of the initial and final state files ! - CALL FNAME (NAME) + CALL FNAME (NAME) ! ! Open, check, load data from, and close, the initial and final state ! .csl files. These files are then merged to one file. ! - CALL MRGCSL (NAME) + CALL MRGCSL (NAME) ! ! Open, check, load data from, and close, the merged .csl file ! - CALL SETCSLM + CALL SETCSLM ! ! Read mixing coefficients ! @@ -136,24 +136,24 @@ PROGRAM BIOSCL ! ! Get the remaining information ! - CALL GETOSD (ISOFILE,NAME) + CALL GETOSD (ISOFILE,NAME) ! ! Open and append a summary of the inputs to the .sum file ! ILBL = 0 - CALL STRSUM (NAME, INPCI,ILBL) + CALL STRSUM (NAME, INPCI,ILBL) ! ! Set up the table of logarithms of factorials ! - CALL FACTT + CALL FACTT ! ! Proceed with the transition calculation ! - CALL OSCL (NAME) + CALL OSCL (NAME) ! ! Print completion message ! CALL STOPTIME (ncount1, 'RTRANSITION') ! - STOP - END PROGRAM BIOSCL + STOP + END PROGRAM BIOSCL diff --git a/src/appl/rtransition90/brkt.f90 b/src/appl/rtransition90/brkt.f90 index 4dbbc1b4e..64badbd48 100644 --- a/src/appl/rtransition90/brkt.f90 +++ b/src/appl/rtransition90/brkt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BRKT + SUBROUTINE BRKT ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE BRKT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:56:42 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:56:42 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE grid_C USE tatb_C @@ -23,45 +23,45 @@ SUBROUTINE BRKT !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET + REAL(DOUBLE) :: RESULT !----------------------------------------------- - + ! - DO I = 1, NWII - DO J = 1, NWFF - IF (NAKII(I) /= NAKFF(J)) CYCLE + DO I = 1, NWII + DO J = 1, NWFF + IF (NAKII(I) /= NAKFF(J)) CYCLE ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.D0 - DO L = 2, MTP + TA(1) = 0.D0 + DO L = 2, MTP TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - - BRAKET(I,J) = RESULT - + CALL QUAD (RESULT) + + BRAKET(I,J) = RESULT + WRITE (*,9) '<',NPII(I),NHII(I),'|',NPFF(J),NHFF(J),'> =', & - BRAKET(I,J) - END DO - END DO + BRAKET(I,J) + END DO + END DO ! - 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) - - RETURN - END SUBROUTINE BRKT + 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) + + RETURN + END SUBROUTINE BRKT diff --git a/src/appl/rtransition90/brkt_I.f90 b/src/appl/rtransition90/brkt_I.f90 index 77bbd1ec6..0d5138998 100644 --- a/src/appl/rtransition90/brkt_I.f90 +++ b/src/appl/rtransition90/brkt_I.f90 @@ -1,9 +1,9 @@ - MODULE brkt_I + MODULE brkt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE brkt - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE brkt + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/connect.f90 b/src/appl/rtransition90/connect.f90 index fb2922ac4..3e8e748ad 100644 --- a/src/appl/rtransition90/connect.f90 +++ b/src/appl/rtransition90/connect.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CONNECT + SUBROUTINE CONNECT ! * ! The position of an orbital in the merged list is connected to * ! the positions in the initial and final state lists * @@ -8,20 +8,20 @@ SUBROUTINE CONNECT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! !ww INTEGER PNTRIQ @@ -30,21 +30,21 @@ SUBROUTINE CONNECT ! ! Initialize ! - NNII(:NW) = 0.D0 - NNFF(:NW) = 0.D0 + NNII(:NW) = 0.D0 + NNFF(:NW) = 0.D0 ! ! Loop over the orbitals in the merged list ! - DO I = 1, NW - DO J = 1, NWII - IF (NP(I)/=NPII(J) .OR. NAK(I)/=NAKII(J)) CYCLE - NNII(I) = J - END DO - DO J = 1, NWFF - IF (NP(I)/=NPFF(J) .OR. NAK(I)/=NAKFF(J)) CYCLE - NNFF(I) = J - END DO - END DO - - RETURN - END SUBROUTINE CONNECT + DO I = 1, NW + DO J = 1, NWII + IF (NP(I)/=NPII(J) .OR. NAK(I)/=NAKII(J)) CYCLE + NNII(I) = J + END DO + DO J = 1, NWFF + IF (NP(I)/=NPFF(J) .OR. NAK(I)/=NAKFF(J)) CYCLE + NNFF(I) = J + END DO + END DO + + RETURN + END SUBROUTINE CONNECT diff --git a/src/appl/rtransition90/connect_I.f90 b/src/appl/rtransition90/connect_I.f90 index c0ca14809..54dd2daaf 100644 --- a/src/appl/rtransition90/connect_I.f90 +++ b/src/appl/rtransition90/connect_I.f90 @@ -1,9 +1,9 @@ - MODULE connect_I + MODULE connect_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE connect - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE connect + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/cpmix.f90 b/src/appl/rtransition90/cpmix.f90 index e48709a4d..ad41d1909 100644 --- a/src/appl/rtransition90/cpmix.f90 +++ b/src/appl/rtransition90/cpmix.f90 @@ -1,13 +1,13 @@ !************************************************************************ - SUBROUTINE CPMIX(NAME, INPCI) + SUBROUTINE CPMIX(NAME, INPCI) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -16,64 +16,64 @@ SUBROUTINE CPMIX(NAME, INPCI) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: INPCI - CHARACTER , INTENT(INOUT) :: NAME(2)*24 + INTEGER , INTENT(IN) :: INPCI + CHARACTER , INTENT(INOUT) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IOS, NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK, IBLK, IB, & - NCF, NVEC, IATJP, IASPA, I, J + NCF, NVEC, IATJP, IASPA, I, J REAL(DOUBLE),DIMENSION(:), pointer :: EVAL, EVEC INTEGER,DIMENSION(:), pointer :: IVEC - REAL(DOUBLE) :: EAV - CHARACTER :: G92MIX*6 + REAL(DOUBLE) :: EAV + CHARACTER :: G92MIX*6 !----------------------------------------------- - - NAME(2) = TRIM(NAME(1))//'_CP' - IF (INPCI == 0) THEN + + NAME(2) = TRIM(NAME(1))//'_CP' + IF (INPCI == 0) THEN OPEN(UNIT=78, FILE=TRIM(NAME(2))//'.cbm', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - ELSE + 'UNKNOWN', POSITION='asis') + ELSE OPEN(UNIT=78, FILE=TRIM(NAME(2))//'.bm', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - ENDIF - IF (INPCI == 0) THEN + 'UNKNOWN', POSITION='asis') + ENDIF + IF (INPCI == 0) THEN OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.cbm', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ELSE + 'OLD', POSITION='asis') + ELSE OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.bm', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ENDIF - READ (68, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - WRITE (78) G92MIX - READ (68) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - WRITE (78) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - - DO IBLK = 1, NBLOCK - READ (68) IB, NCF, NVEC, IATJP, IASPA - WRITE (78) IB, NCF, NVEC, IATJP, IASPA - WRITE (*,*) IB, NCF, NVEC, IATJP, IASPA - CALL ALLOC (EVAL, NVEC, 'EVAL', 'CPMIX') - CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'CPMIX') - CALL ALLOC (IVEC, NVEC, 'IVEC', 'CPMIX') - READ (68) (IVEC(I),I=1,NVEC) - READ (68) EAV, (EVAL(I),I=1,NVEC) - READ (68) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) - - WRITE (78) (IVEC(I),I=1,NVEC) - WRITE (78) EAV, (EVAL(I),I=1,NVEC) - WRITE (78) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) - CALL DALLOC (EVAL, 'EVAL', 'CPMIX') - CALL DALLOC (EVEC, 'EVEC', 'CPMIX') - CALL DALLOC (IVEC, 'IVEC', 'CPMIX') - END DO - NAME(2) = NAME(1) - CLOSE(68) - CLOSE(78) - RETURN - END SUBROUTINE CPMIX + 'OLD', POSITION='asis') + ENDIF + READ (68, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + WRITE (78) G92MIX + READ (68) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + WRITE (78) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + + DO IBLK = 1, NBLOCK + READ (68) IB, NCF, NVEC, IATJP, IASPA + WRITE (78) IB, NCF, NVEC, IATJP, IASPA + WRITE (*,*) IB, NCF, NVEC, IATJP, IASPA + CALL ALLOC (EVAL, NVEC, 'EVAL', 'CPMIX') + CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'CPMIX') + CALL ALLOC (IVEC, NVEC, 'IVEC', 'CPMIX') + READ (68) (IVEC(I),I=1,NVEC) + READ (68) EAV, (EVAL(I),I=1,NVEC) + READ (68) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + + WRITE (78) (IVEC(I),I=1,NVEC) + WRITE (78) EAV, (EVAL(I),I=1,NVEC) + WRITE (78) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + CALL DALLOC (EVAL, 'EVAL', 'CPMIX') + CALL DALLOC (EVEC, 'EVEC', 'CPMIX') + CALL DALLOC (IVEC, 'IVEC', 'CPMIX') + END DO + NAME(2) = NAME(1) + CLOSE(68) + CLOSE(78) + RETURN + END SUBROUTINE CPMIX diff --git a/src/appl/rtransition90/cpmix_I.f90 b/src/appl/rtransition90/cpmix_I.f90 index dc6c36a05..5b605f188 100644 --- a/src/appl/rtransition90/cpmix_I.f90 +++ b/src/appl/rtransition90/cpmix_I.f90 @@ -1,11 +1,11 @@ - MODULE cpmix_I + MODULE cpmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cpmix (NAME, INPCI) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME - INTEGER, INTENT(IN) :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cpmix (NAME, INPCI) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME + INTEGER, INTENT(IN) :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/csfm.f90 b/src/appl/rtransition90/csfm.f90 index 40cf634fe..a699ca39c 100644 --- a/src/appl/rtransition90/csfm.f90 +++ b/src/appl/rtransition90/csfm.f90 @@ -9,8 +9,8 @@ SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) ! Modified for different initial and final state orbitals * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -62,7 +62,7 @@ SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) JPAR = (IASPARFF(LEV2)+3)/2 JPARI = LABP(IPAR) JPARJ = LABP(JPAR) - + IF (LDBPR(18)) THEN WRITE (*,302) IVECFF(LEV2), JLABJ, JPARJ, IVECII(LEV1), & JLABI, JPARI diff --git a/src/appl/rtransition90/csfm_I.f90 b/src/appl/rtransition90/csfm_I.f90 index 001054b6e..e9bf330b8 100644 --- a/src/appl/rtransition90/csfm_I.f90 +++ b/src/appl/rtransition90/csfm_I.f90 @@ -1,12 +1,12 @@ - MODULE csfm_I + MODULE csfm_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE REAL(DOUBLE), INTENT(OUT) :: asfa, asfb INTEGER, INTENT(IN) :: lev1, lev2 - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/engout1.f90 b/src/appl/rtransition90/engout1.f90 index a444ec77a..a4ea98b94 100644 --- a/src/appl/rtransition90/engout1.f90 +++ b/src/appl/rtransition90/engout1.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) + SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,56 +13,56 @@ SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: AUCM, AUEV, CCMS, FASI, FBSI USE jlabl_C, LABJ=>JLBR, LABP=>JLBP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NN - INTEGER :: MODE - INTEGER , INTENT(IN) :: K - REAL(DOUBLE) , INTENT(IN) :: EAV - INTEGER , INTENT(IN) :: JTOT(NN) - INTEGER , INTENT(IN) :: IPAR(NN) - INTEGER , INTENT(IN) :: ILEV(NN) - REAL(DOUBLE) , INTENT(IN) :: E(NN) + INTEGER , INTENT(IN) :: NN + INTEGER :: MODE + INTEGER , INTENT(IN) :: K + REAL(DOUBLE) , INTENT(IN) :: EAV + INTEGER , INTENT(IN) :: JTOT(NN) + INTEGER , INTENT(IN) :: IPAR(NN) + INTEGER , INTENT(IN) :: ILEV(NN) + REAL(DOUBLE) , INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - IF (K == 1) WRITE (24, 299) - IF (K == 2) WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM - END DO + IF (K == 1) WRITE (24, 299) + IF (K == 2) WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM + END DO ! - RETURN + RETURN ! - 299 FORMAT('Eigenenergies for the initial state list') - 300 FORMAT('Eigenenergies for the final state list') - 301 FORMAT('Level J Parity',10X,'Hartrees',18X,'Kaysers') - 302 FORMAT(1I3,4X,2A4,1P,2D25.15) - 303 FORMAT('Energy of each level relative to immediately lower',' level:') - 304 FORMAT('Energy of each level relative to lowest level:') - RETURN + 299 FORMAT('Eigenenergies for the initial state list') + 300 FORMAT('Eigenenergies for the final state list') + 301 FORMAT('Level J Parity',10X,'Hartrees',18X,'Kaysers') + 302 FORMAT(1I3,4X,2A4,1P,2D25.15) + 303 FORMAT('Energy of each level relative to immediately lower',' level:') + 304 FORMAT('Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUT1 + END SUBROUTINE ENGOUT1 diff --git a/src/appl/rtransition90/engout1_I.f90 b/src/appl/rtransition90/engout1_I.f90 index 04de7a381..85abe94a0 100644 --- a/src/appl/rtransition90/engout1_I.f90 +++ b/src/appl/rtransition90/engout1_I.f90 @@ -1,19 +1,19 @@ - MODULE engout1_I + MODULE engout1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE engout1 (EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT - INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER :: MODE + SUBROUTINE engout1 (EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT + INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER :: MODE !VAST...Dummy argument MODE is not referenced in this routine. - INTEGER, INTENT(IN) :: K - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: K + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/fname.f90 b/src/appl/rtransition90/fname.f90 index e16266943..b8cd8d68c 100644 --- a/src/appl/rtransition90/fname.f90 +++ b/src/appl/rtransition90/fname.f90 @@ -1,49 +1,49 @@ !*********************************************************************** ! * - SUBROUTINE FNAME(NAME) + SUBROUTINE FNAME(NAME) ! * ! Determines the name of the initial and final states * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! ! ! Obtain the names of the initial and final state files ! - 1 CONTINUE - WRITE (6, *) ' Name of the Initial state' - READ (*, '(A)') NAME(1) - WRITE (6, *) ' Name of the Final state' - READ (*, '(A)') NAME(2) + 1 CONTINUE + WRITE (6, *) ' Name of the Initial state' + READ (*, '(A)') NAME(1) + WRITE (6, *) ' Name of the Final state' + READ (*, '(A)') NAME(2) ! - J = INDEX(NAME(1),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(1),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! - J = INDEX(NAME(2),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF - - RETURN - END SUBROUTINE FNAME + J = INDEX(NAME(2),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF + + RETURN + END SUBROUTINE FNAME diff --git a/src/appl/rtransition90/fname_I.f90 b/src/appl/rtransition90/fname_I.f90 index 9e4149e7f..0bb6379c6 100644 --- a/src/appl/rtransition90/fname_I.f90 +++ b/src/appl/rtransition90/fname_I.f90 @@ -1,11 +1,11 @@ - MODULE fname_I + MODULE fname_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fname (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + SUBROUTINE fname (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/getosd.f90 b/src/appl/rtransition90/getosd.f90 index b881d8512..f0f78ac7a 100644 --- a/src/appl/rtransition90/getosd.f90 +++ b/src/appl/rtransition90/getosd.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETOSD(isofile,NAME) + SUBROUTINE GETOSD(isofile,NAME) ! * ! Interactively determines the data governing the transition prob- * ! lem. * @@ -8,11 +8,11 @@ SUBROUTINE GETOSD(isofile,NAME) ! Written by Per Jonsson Last revision: June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP @@ -26,161 +26,161 @@ SUBROUTINE GETOSD(isofile,NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE getrmp_I - USE setqic_I - USE radgrd_I - USE lodrwfi_I - USE lodrwff_I - USE brkt_I + USE getyn_I + USE setiso_I + USE getrmp_I + USE setqic_I + USE radgrd_I + USE lodrwfi_I + USE lodrwff_I + USE brkt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 CHARACTER(LEN=*) :: isofile !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - LOGICAL :: YES - CHARACTER :: CUNITS*4, ANSWER + INTEGER :: I + LOGICAL :: YES + CHARACTER :: CUNITS*4, ANSWER !----------------------------------------------- ! ! Open, check, load data from, and close the .iso file ! -!GG CALL SETISO ('isodata') +!GG CALL SETISO ('isodata') CALL SETISO (isofile) ! ! Determine the physical effects specifications ! - IF (NDEF /= 0) THEN - WRITE (6, *) 'The physical speed of light in' - WRITE (6, *) ' atomic units is', CVAC, ';' - WRITE (6, *) ' revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter the revised value:' - READ (5, *) C - ELSE - C = CVAC - ENDIF - ELSE - C = CVAC - ENDIF -! - LFORDR = .FALSE. - ICCUT = 0 + IF (NDEF /= 0) THEN + WRITE (6, *) 'The physical speed of light in' + WRITE (6, *) ' atomic units is', CVAC, ';' + WRITE (6, *) ' revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter the revised value:' + READ (5, *) C + ELSE + C = CVAC + ENDIF + ELSE + C = CVAC + ENDIF +! + LFORDR = .FALSE. + ICCUT = 0 ! ! Determine the multipolarity and parity of the transitions ! - CALL GETRMP + CALL GETRMP ! ! Determine the units for the printout and other options ! - LTC = .FALSE. -! - IF (NDEF /= 0) THEN - WRITE (6, *) 'Which units are to be used to' - WRITE (6, *) ' express the transition energies?' - WRITE (6, *) ' A : Angstrom:' - WRITE (6, *) ' eV : electron volts;' - WRITE (6, *) ' Hart : Hartree atomic units;' - WRITE (6, *) ' Hz : Hertz;' - WRITE (6, *) ' Kays : Kaysers [cm**(-1)];' - 2 CONTINUE - READ (*, '(A)') CUNITS - IF (CUNITS(1:1) == 'A') THEN - LTC(1) = .TRUE. - ELSE IF (CUNITS(1:2) == 'eV') THEN - LTC(2) = .TRUE. - ELSE IF (CUNITS(1:4) == 'Hart') THEN - LTC(3) = .TRUE. - ELSE IF (CUNITS(1:2) == 'Hz') THEN - LTC(4) = .TRUE. - ELSE IF (CUNITS(1:4) == 'Kays') THEN - LTC(5) = .TRUE. - ELSE - WRITE (6, *) 'GETOSD: Unable to interpret string;' - WRITE (6, *) ' reenter ...' - GO TO 2 - ENDIF - ELSE - LTC(5) = .TRUE. - ENDIF -! -! WRITE (6, *) 'Sort transitions by energy?' -! YES = GETYN() -! IF (YES) LTC(6) = .TRUE. -! - IF (NDEF /= 0) THEN - WRITE (6, *) 'Einstein A and B coefficients are' - WRITE (6, *) ' printed in SI units; use Hartree' - WRITE (6, *) ' atomic units instead?' - YES = GETYN() - IF (YES) LTC(7) = .TRUE. - ELSE - LTC(7) = .FALSE. - ENDIF + LTC = .FALSE. +! + IF (NDEF /= 0) THEN + WRITE (6, *) 'Which units are to be used to' + WRITE (6, *) ' express the transition energies?' + WRITE (6, *) ' A : Angstrom:' + WRITE (6, *) ' eV : electron volts;' + WRITE (6, *) ' Hart : Hartree atomic units;' + WRITE (6, *) ' Hz : Hertz;' + WRITE (6, *) ' Kays : Kaysers [cm**(-1)];' + 2 CONTINUE + READ (*, '(A)') CUNITS + IF (CUNITS(1:1) == 'A') THEN + LTC(1) = .TRUE. + ELSE IF (CUNITS(1:2) == 'eV') THEN + LTC(2) = .TRUE. + ELSE IF (CUNITS(1:4) == 'Hart') THEN + LTC(3) = .TRUE. + ELSE IF (CUNITS(1:2) == 'Hz') THEN + LTC(4) = .TRUE. + ELSE IF (CUNITS(1:4) == 'Kays') THEN + LTC(5) = .TRUE. + ELSE + WRITE (6, *) 'GETOSD: Unable to interpret string;' + WRITE (6, *) ' reenter ...' + GO TO 2 + ENDIF + ELSE + LTC(5) = .TRUE. + ENDIF +! +! WRITE (6, *) 'Sort transitions by energy?' +! YES = GETYN() +! IF (YES) LTC(6) = .TRUE. +! + IF (NDEF /= 0) THEN + WRITE (6, *) 'Einstein A and B coefficients are' + WRITE (6, *) ' printed in SI units; use Hartree' + WRITE (6, *) ' atomic units instead?' + YES = GETYN() + IF (YES) LTC(7) = .TRUE. + ELSE + LTC(7) = .FALSE. + ENDIF ! ! Determine the parameters controlling the radial grid ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF .. should be Z-dependent RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF - ENDIF + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical proceduRes ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Load the initial state radial wavefunctions. ! - CALL LODRWFI (NAME(1)) + CALL LODRWFI (NAME(1)) ! ! Load the final state radial wavefunctions. ! - CALL LODRWFF (NAME(2)) - + CALL LODRWFF (NAME(2)) + ! Construct the radial overlap matrix. ! - CALL BRKT - - RETURN - END SUBROUTINE GETOSD + CALL BRKT + + RETURN + END SUBROUTINE GETOSD diff --git a/src/appl/rtransition90/getosd_I.f90 b/src/appl/rtransition90/getosd_I.f90 index f73756899..dccba3e2d 100644 --- a/src/appl/rtransition90/getosd_I.f90 +++ b/src/appl/rtransition90/getosd_I.f90 @@ -1,11 +1,11 @@ - MODULE getosd_I + MODULE getosd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getosd (isofile,NAME) + SUBROUTINE getosd (isofile,NAME) CHARACTER(LEN=*):: isofile - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/getrmp.f90 b/src/appl/rtransition90/getrmp.f90 index d426c2f40..2ba2921a6 100644 --- a/src/appl/rtransition90/getrmp.f90 +++ b/src/appl/rtransition90/getrmp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETRMP + SUBROUTINE GETRMP ! * ! Interactively determines the list of radiation multipolarities * ! and parities. This is loadad into COMMON/OSC6/. * @@ -10,131 +10,131 @@ SUBROUTINE GETRMP ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man - USE OFFD_C + USE OFFD_C USE osc_C, ONLY: NKP, KP !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NDKP, ISTART, I, IEND, LENTH, IOS, MULT - REAL, DIMENSION(3) :: CNUM - LOGICAL :: LELEC, LMAGN, YES - CHARACTER :: RECORD*256, RECI + INTEGER :: NDKP, ISTART, I, IEND, LENTH, IOS, MULT + REAL, DIMENSION(3) :: CNUM + LOGICAL :: LELEC, LMAGN, YES + CHARACTER :: RECORD*256, RECI !----------------------------------------------- ! ! ! Initial allocation for PNTRKP ! - NDKP = 1 - CALL ALLOC (KP, NDKP, 'KP', 'GETRMP' ) + NDKP = 1 + CALL ALLOC (KP, NDKP, 'KP', 'GETRMP' ) ! ! Entry message ! - 1 CONTINUE - WRITE (6, *) 'Enter the list of transition specifications' - WRITE (6, *) ' e.g., E1,M2 or E1 M2 or E1;M2 :' + 1 CONTINUE + WRITE (6, *) 'Enter the list of transition specifications' + WRITE (6, *) ' e.g., E1,M2 or E1 M2 or E1;M2 :' ! ! Initialise NKP ! - 2 CONTINUE - READ (*, '(A)') RECORD - NKP = 0 + 2 CONTINUE + READ (*, '(A)') RECORD + NKP = 0 ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - 3 CONTINUE - RECI = RECORD(I:I) - IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN - IF (ISTART == 0) ISTART = I - ELSE - IF (ISTART /= 0) THEN - IEND = I - 1 - RECI = RECORD(ISTART:ISTART) - IF (RECI == 'E') THEN - LELEC = .TRUE. - LMAGN = .FALSE. - ELSE IF (RECI == 'M') THEN - LELEC = .FALSE. - LMAGN = .TRUE. - ELSE - WRITE (6, *) 'GETRMP: Transitions must be of type' - WRITE (6, *) ' E or type M; reenter ...' - GO TO 2 - ENDIF - LENTH = IEND - ISTART - IF (LENTH /= 1) THEN - WRITE (6, *) 'GETRMP: Transition multipolarities' - WRITE (6, *) ' must be integers between 1 and 9;' - WRITE (6, *) ' reenter ...' - GO TO 2 - ENDIF - RECI = RECORD(IEND:IEND) - READ (RECI, '(1I1)', IOSTAT=IOS) MULT - IF (IOS /= 0) THEN - WRITE (6, *) 'GETRMP: Unable to decode multipolarity' - WRITE (6, *) ' '//RECI//'; reenter ...' - GO TO 2 - ENDIF - NKP = NKP + 1 - IF (NKP > NDKP) THEN - CALL RALLOC (KP, NKP, 'KP', 'GETRMP' ) - NDKP = NKP - ENDIF - IF (LELEC) THEN - KP(NKP) = MULT*(-1)**MULT - ELSE IF (LMAGN) THEN - KP(NKP) = MULT*(-1)**(MULT + 1) - ENDIF - ISTART = 0 - ENDIF - ENDIF -! - IF (I < 256) THEN - I = I + 1 - GO TO 3 - ENDIF -! - IF (NKP == 0) GO TO 1 + ISTART = 0 + I = 1 + 3 CONTINUE + RECI = RECORD(I:I) + IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN + IF (ISTART == 0) ISTART = I + ELSE + IF (ISTART /= 0) THEN + IEND = I - 1 + RECI = RECORD(ISTART:ISTART) + IF (RECI == 'E') THEN + LELEC = .TRUE. + LMAGN = .FALSE. + ELSE IF (RECI == 'M') THEN + LELEC = .FALSE. + LMAGN = .TRUE. + ELSE + WRITE (6, *) 'GETRMP: Transitions must be of type' + WRITE (6, *) ' E or type M; reenter ...' + GO TO 2 + ENDIF + LENTH = IEND - ISTART + IF (LENTH /= 1) THEN + WRITE (6, *) 'GETRMP: Transition multipolarities' + WRITE (6, *) ' must be integers between 1 and 9;' + WRITE (6, *) ' reenter ...' + GO TO 2 + ENDIF + RECI = RECORD(IEND:IEND) + READ (RECI, '(1I1)', IOSTAT=IOS) MULT + IF (IOS /= 0) THEN + WRITE (6, *) 'GETRMP: Unable to decode multipolarity' + WRITE (6, *) ' '//RECI//'; reenter ...' + GO TO 2 + ENDIF + NKP = NKP + 1 + IF (NKP > NDKP) THEN + CALL RALLOC (KP, NKP, 'KP', 'GETRMP' ) + NDKP = NKP + ENDIF + IF (LELEC) THEN + KP(NKP) = MULT*(-1)**MULT + ELSE IF (LMAGN) THEN + KP(NKP) = MULT*(-1)**(MULT + 1) + ENDIF + ISTART = 0 + ENDIF + ENDIF +! + IF (I < 256) THEN + I = I + 1 + GO TO 3 + ENDIF +! + IF (NKP == 0) GO TO 1 ! ! Trim array to the exact size ! - IF (NDKP /= NKP) CALL RALLOC (KP, NKP, 'KP', 'GETRMP') + IF (NDKP /= NKP) CALL RALLOC (KP, NKP, 'KP', 'GETRMP') ! ! If M1 or E2 inquire if the transitions are between levels ! with different J quantum numbers. ! - DO I = 1, NKP - IF (KP(I) == 1) THEN - WRITE (*, *) 'M1 transitions only between levels with different J?' - YES = GETYN() - IF (YES) THEN - NOFFD1 = 1 - ELSE - NOFFD1 = 0 - ENDIF - ENDIF - IF (KP(I) /= 2) CYCLE - WRITE (*, *) 'E2 transitions only between levels with different J?' - YES = GETYN() - IF (YES) THEN - NOFFD2 = 1 - ELSE - NOFFD2 = 0 - ENDIF - END DO -! - RETURN - END SUBROUTINE GETRMP + DO I = 1, NKP + IF (KP(I) == 1) THEN + WRITE (*, *) 'M1 transitions only between levels with different J?' + YES = GETYN() + IF (YES) THEN + NOFFD1 = 1 + ELSE + NOFFD1 = 0 + ENDIF + ENDIF + IF (KP(I) /= 2) CYCLE + WRITE (*, *) 'E2 transitions only between levels with different J?' + YES = GETYN() + IF (YES) THEN + NOFFD2 = 1 + ELSE + NOFFD2 = 0 + ENDIF + END DO +! + RETURN + END SUBROUTINE GETRMP diff --git a/src/appl/rtransition90/getrmp_I.f90 b/src/appl/rtransition90/getrmp_I.f90 index e72269a88..24dd537a2 100644 --- a/src/appl/rtransition90/getrmp_I.f90 +++ b/src/appl/rtransition90/getrmp_I.f90 @@ -1,9 +1,9 @@ - MODULE getrmp_I + MODULE getrmp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getrmp - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getrmp + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/ichkq1.f90 b/src/appl/rtransition90/ichkq1.f90 index 400f8b5d4..95a00922b 100644 --- a/src/appl/rtransition90/ichkq1.f90 +++ b/src/appl/rtransition90/ichkq1.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ICHKQ1 (JA, JB) + INTEGER FUNCTION ICHKQ1 (JA, JB) ! * ! This routine is to check the occupation condition for one electron * ! operator. * @@ -10,43 +10,43 @@ INTEGER FUNCTION ICHKQ1 (JA, JB) ! Yu Zou Last revision: 8/16/00 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE orb_C, ONLY: NCF, NW, IQA USE debug_C, ONLY: LDPA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB + INTEGER :: JA + INTEGER :: JB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, I, IQA, IQB + INTEGER :: K, I, IQA, IQB !----------------------------------------------- ! ! - ICHKQ1 = 0 - K = 0 - DO I = 1, NW - IQA = IQ(I,JA) - IQB = IQ(I,JB) - IF (IQA == IQB) CYCLE - K = K + 1 - IF (K > 2) RETURN - IF (IABS(IQA - IQB) <= 1) CYCLE - RETURN - END DO - IF (K==2 .OR. K==0) ICHKQ1 = 1 - RETURN - END FUNCTION ICHKQ1 + ICHKQ1 = 0 + K = 0 + DO I = 1, NW + IQA = IQ(I,JA) + IQB = IQ(I,JB) + IF (IQA == IQB) CYCLE + K = K + 1 + IF (K > 2) RETURN + IF (IABS(IQA - IQB) <= 1) CYCLE + RETURN + END DO + IF (K==2 .OR. K==0) ICHKQ1 = 1 + RETURN + END FUNCTION ICHKQ1 diff --git a/src/appl/rtransition90/ichkq1_I.f90 b/src/appl/rtransition90/ichkq1_I.f90 index c25006c51..83702e1dd 100644 --- a/src/appl/rtransition90/ichkq1_I.f90 +++ b/src/appl/rtransition90/ichkq1_I.f90 @@ -1,11 +1,11 @@ - MODULE ichkq1_I + MODULE ichkq1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ichkq1 (JA, JB) - INTEGER :: JA - INTEGER :: JB - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ichkq1 (JA, JB) + INTEGER :: JA + INTEGER :: JB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/iqr.f90 b/src/appl/rtransition90/iqr.f90 index 73d6ab7c1..3583c7b14 100644 --- a/src/appl/rtransition90/iqr.f90 +++ b/src/appl/rtransition90/iqr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION IQR (ISUBSH, ICSF) + INTEGER FUNCTION IQR (ISUBSH, ICSF) ! * ! IQR is the occupation of subshell ISUBSH in CSF ICSF. * ! * @@ -8,8 +8,8 @@ INTEGER FUNCTION IQR (ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -19,12 +19,12 @@ INTEGER FUNCTION IQR (ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! ! IQR = IQA(isubsh,icsf) ! - RETURN - END FUNCTION IQR + RETURN + END FUNCTION IQR diff --git a/src/appl/rtransition90/iqr_I.f90 b/src/appl/rtransition90/iqr_I.f90 index d2c32bd64..d8f77a112 100644 --- a/src/appl/rtransition90/iqr_I.f90 +++ b/src/appl/rtransition90/iqr_I.f90 @@ -1,11 +1,11 @@ - MODULE iqr_I + MODULE iqr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION iqr (ISUBSH, ICSF) - INTEGER, INTENT(IN) :: ISUBSH - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION iqr (ISUBSH, ICSF) + INTEGER, INTENT(IN) :: ISUBSH + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/isparr.f90 b/src/appl/rtransition90/isparr.f90 index d94611faa..ab0aa32bb 100644 --- a/src/appl/rtransition90/isparr.f90 +++ b/src/appl/rtransition90/isparr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ISPARR (ICSF) + INTEGER FUNCTION ISPARR (ICSF) ! * ! ISPARR is the value of P for CSF number ICSF. * ! * @@ -8,8 +8,8 @@ INTEGER FUNCTION ISPARR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -25,21 +25,21 @@ INTEGER FUNCTION ISPARR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN isparr = jcupar(NNNW,icsf) - IF (ISPARR > 127) ISPARR = ISPARR - 256 - ISPARR = SIGN(1,ISPARR) - ELSE - WRITE (6, *) 'ISPARR: Argument ICSF is out of range.' - STOP - ENDIF + IF (ISPARR > 127) ISPARR = ISPARR - 256 + ISPARR = SIGN(1,ISPARR) + ELSE + WRITE (6, *) 'ISPARR: Argument ICSF is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION ISPARR + RETURN + END FUNCTION ISPARR diff --git a/src/appl/rtransition90/isparr_I.f90 b/src/appl/rtransition90/isparr_I.f90 index 273e7a7a0..85f836870 100644 --- a/src/appl/rtransition90/isparr_I.f90 +++ b/src/appl/rtransition90/isparr_I.f90 @@ -1,10 +1,10 @@ - MODULE isparr_I + MODULE isparr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION isparr (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION isparr (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/itjpor.f90 b/src/appl/rtransition90/itjpor.f90 index c27f07839..566545e2e 100644 --- a/src/appl/rtransition90/itjpor.f90 +++ b/src/appl/rtransition90/itjpor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITJPOR (ICSF) + INTEGER FUNCTION ITJPOR (ICSF) ! * ! ITJPOR is the value of 2J+1 for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ITJPOR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPAR @@ -25,17 +25,17 @@ INTEGER FUNCTION ITJPOR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN itjpor = jcupar(NNNW,icsf) - IF (ITJPOR > 127) ITJPOR = 256 - ITJPOR + IF (ITJPOR > 127) ITJPOR = 256 - ITJPOR ITJPOR = IABS (ITJPOR) - ELSE - WRITE (6, *) 'ITJPOR: Argument ICSF is out of range.' - STOP - ENDIF + ELSE + WRITE (6, *) 'ITJPOR: Argument ICSF is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION ITJPOR + RETURN + END FUNCTION ITJPOR diff --git a/src/appl/rtransition90/itjpor_I.f90 b/src/appl/rtransition90/itjpor_I.f90 index 8422a1047..0125b7437 100644 --- a/src/appl/rtransition90/itjpor_I.f90 +++ b/src/appl/rtransition90/itjpor_I.f90 @@ -1,10 +1,10 @@ - MODULE itjpor_I + MODULE itjpor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itjpor (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION itjpor (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/jcupr.f90 b/src/appl/rtransition90/jcupr.f90 index 01790531e..f6da6359b 100644 --- a/src/appl/rtransition90/jcupr.f90 +++ b/src/appl/rtransition90/jcupr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION JCUPR (LOC, ICSF) + INTEGER FUNCTION JCUPR (LOC, ICSF) ! * ! JCUPR is the 2J+1 value of the LOCth nontrivial intermediate ang- * ! ular momentum in CSF ICSF. * @@ -9,11 +9,11 @@ INTEGER FUNCTION JCUPR (LOC, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW use orb_C, ONLY: NWR, NCFR @@ -25,21 +25,21 @@ INTEGER FUNCTION JCUPR (LOC, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: LOC - INTEGER :: ICSF + INTEGER, INTENT(IN) :: LOC + INTEGER :: ICSF !----------------------------------------------- ! - IF (LOC>=1 .AND. LOC<=NWR-1) THEN - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (LOC>=1 .AND. LOC<=NWR-1) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN jcupr = jcupar(loc,icsf) - ELSE - WRITE (6, *) 'JCUPR: Argument ICSF is out of range.' - STOP - ENDIF - ELSE - WRITE (6, *) 'JCUPR: Argument LOC is out of range.' - STOP - ENDIF + ELSE + WRITE (6, *) 'JCUPR: Argument ICSF is out of range.' + STOP + ENDIF + ELSE + WRITE (6, *) 'JCUPR: Argument LOC is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION JCUPR + RETURN + END FUNCTION JCUPR diff --git a/src/appl/rtransition90/jcupr_I.f90 b/src/appl/rtransition90/jcupr_I.f90 index 18f6f24c3..36b302349 100644 --- a/src/appl/rtransition90/jcupr_I.f90 +++ b/src/appl/rtransition90/jcupr_I.f90 @@ -1,11 +1,11 @@ - MODULE jcupr_I + MODULE jcupr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jcupr (LOC, ICSF) - INTEGER, INTENT(IN) :: LOC - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION jcupr (LOC, ICSF) + INTEGER, INTENT(IN) :: LOC + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/jqsr.f90 b/src/appl/rtransition90/jqsr.f90 index a9655d684..1e5df879b 100644 --- a/src/appl/rtransition90/jqsr.f90 +++ b/src/appl/rtransition90/jqsr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) + INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) ! * ! JQSR is a subshell quantum number for subshell ISUBSH in configu- * ! ration state function ICSF: the seniority if IWHICH is 1; the * @@ -10,11 +10,11 @@ INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JQSAR @@ -26,12 +26,12 @@ INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! jqsr = jqsar(isubsh,iwhich,icsf) ! - RETURN - END FUNCTION JQSR + RETURN + END FUNCTION JQSR diff --git a/src/appl/rtransition90/jqsr_I.f90 b/src/appl/rtransition90/jqsr_I.f90 index 895b642fb..5026e5bd8 100644 --- a/src/appl/rtransition90/jqsr_I.f90 +++ b/src/appl/rtransition90/jqsr_I.f90 @@ -1,12 +1,12 @@ - MODULE jqsr_I + MODULE jqsr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jqsr (IWHICH, ISUBSH, ICSF) - INTEGER, INTENT(IN) :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION jqsr (IWHICH, ISUBSH, ICSF) + INTEGER, INTENT(IN) :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/ldcsl1.f90 b/src/appl/rtransition90/ldcsl1.f90 index 885fff548..f75d8c253 100644 --- a/src/appl/rtransition90/ldcsl1.f90 +++ b/src/appl/rtransition90/ldcsl1.f90 @@ -9,7 +9,7 @@ SUBROUTINE LDCSL1 (NCORER,NAME) ! * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -44,7 +44,7 @@ SUBROUTINE LDCSL1 (NCORER,NAME) J = INDEX(NAME,' ') OPEN (UNIT = 21,FILE=NAME(1:J-1)//'.c',FORM='FORMATTED', & & STATUS='OLD') - + READ (21,'(1A15)',IOSTAT = IOS) RECORD IF ((IOS .NE. 0) .OR. & & (RECORD(1:15) .NE. 'Core subshells:')) THEN @@ -117,6 +117,6 @@ SUBROUTINE LDCSL1 (NCORER,NAME) CALL DALLOC (JCUPA, 'JCUPA', 'LDCSL1') ! CLOSE (21) - + RETURN END diff --git a/src/appl/rtransition90/ldcsl1_I.f90 b/src/appl/rtransition90/ldcsl1_I.f90 index ccb4a063b..5a90eb9e0 100644 --- a/src/appl/rtransition90/ldcsl1_I.f90 +++ b/src/appl/rtransition90/ldcsl1_I.f90 @@ -1,10 +1,10 @@ - MODULE ldcsl1_I + MODULE ldcsl1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDCSL1 (NCORER,NAME) INTEGER :: ncorer CHARACTER(LEN=24) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/ldcsl2.f90 b/src/appl/rtransition90/ldcsl2.f90 index 8e1759572..c92249632 100644 --- a/src/appl/rtransition90/ldcsl2.f90 +++ b/src/appl/rtransition90/ldcsl2.f90 @@ -1,8 +1,8 @@ !*********************************************************************** ! * - SUBROUTINE LDCSL2(NCORE, NAME) + SUBROUTINE LDCSL2(NCORE, NAME) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- ! * ! Open, check, load data from and close the .csl file. This file * @@ -13,31 +13,31 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE orb_C USE biorb_C - + !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lodcsl_I + USE lodcsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(OUT) :: NCORE - CHARACTER , INTENT(IN) :: NAME*24 + INTEGER , INTENT(OUT) :: NCORE + CHARACTER , INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, IOS, NCORER, I - CHARACTER :: RECORD*15 + INTEGER :: J, IOS, NCORER, I + CHARACTER :: RECORD*15 !----------------------------------------------- ! ! @@ -46,30 +46,30 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! ! The .csl file is FORMATTED; it must exist ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21, FILE=NAME(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - STOP - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + STOP + ENDIF ! ! Load data from the .csl file ! - CALL LODCSL (NCORER) + CALL LODCSL (NCORER) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! ! Check if the core should be redefined ! - NCORE = NCORER + NCORE = NCORER ! DO 3 I = NCORER+1,NW ! IFULLI = NKJ(I)+1 ! DO 2 J = 1,NCF @@ -82,13 +82,13 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! NCORE = NCORE+1 ! 3 CONTINUE ! - NELECFF = NELEC - NWFF = NW - NCFFF = NCF - NHFF(:NW) = NH(:NW) - NPFF(:NW) = NP(:NW) - NAKFF(:NW) = NAK(:NW) - NKLFF(:NW) = NKL(:NW) - NKJFF(:NW) = NKJ(:NW) - RETURN - END SUBROUTINE LDCSL2 + NELECFF = NELEC + NWFF = NW + NCFFF = NCF + NHFF(:NW) = NH(:NW) + NPFF(:NW) = NP(:NW) + NAKFF(:NW) = NAK(:NW) + NKLFF(:NW) = NKL(:NW) + NKJFF(:NW) = NKJ(:NW) + RETURN + END SUBROUTINE LDCSL2 diff --git a/src/appl/rtransition90/ldcsl2_I.f90 b/src/appl/rtransition90/ldcsl2_I.f90 index 99e2caa5c..cf5d3b028 100644 --- a/src/appl/rtransition90/ldcsl2_I.f90 +++ b/src/appl/rtransition90/ldcsl2_I.f90 @@ -1,10 +1,10 @@ - MODULE ldcsl2_I + MODULE ldcsl2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ldcsl2 (NCORE, NAME) - INTEGER, INTENT(OUT) :: NCORE - CHARACTER (LEN = 24), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ldcsl2 (NCORE, NAME) + INTEGER, INTENT(OUT) :: NCORE + CHARACTER (LEN = 24), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/ldlbl1.f90 b/src/appl/rtransition90/ldlbl1.f90 index f1be19065..dddf9c6d5 100644 --- a/src/appl/rtransition90/ldlbl1.f90 +++ b/src/appl/rtransition90/ldlbl1.f90 @@ -11,7 +11,7 @@ SUBROUTINE LDLBL1 (NAME) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rtransition90/ldlbl1_I.f90 b/src/appl/rtransition90/ldlbl1_I.f90 index a6bbe06c5..7152b3063 100644 --- a/src/appl/rtransition90/ldlbl1_I.f90 +++ b/src/appl/rtransition90/ldlbl1_I.f90 @@ -1,9 +1,9 @@ - MODULE ldlbl1_I + MODULE ldlbl1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDLBL1 (NAME) CHARACTER(LEN=24) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/ldlbl2.f90 b/src/appl/rtransition90/ldlbl2.f90 index c747cfd3b..ca121ddc4 100644 --- a/src/appl/rtransition90/ldlbl2.f90 +++ b/src/appl/rtransition90/ldlbl2.f90 @@ -11,7 +11,7 @@ SUBROUTINE LDLBL2 (NAME) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rtransition90/ldlbl2_I.f90 b/src/appl/rtransition90/ldlbl2_I.f90 index 521b5a8a7..fddfa7385 100644 --- a/src/appl/rtransition90/ldlbl2_I.f90 +++ b/src/appl/rtransition90/ldlbl2_I.f90 @@ -1,9 +1,9 @@ - MODULE ldlbl2_I + MODULE ldlbl2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDLBL2 (NAME) CHARACTER(LEN=24) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/lodcslm.f90 b/src/appl/rtransition90/lodcslm.f90 index 75f984d6e..98e540833 100644 --- a/src/appl/rtransition90/lodcslm.f90 +++ b/src/appl/rtransition90/lodcslm.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSLM(NCORE) + SUBROUTINE LODCSLM(NCORE) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -10,125 +10,125 @@ SUBROUTINE LODCSLM(NCORE) ! To accept both block and non-block formats ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE debug_C USE def_C USE orb_C - USE STAT_C - USE TERMS_C + USE STAT_C + USE TERMS_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE + INTEGER :: NCORE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: IOCC - INTEGER , DIMENSION(NW2) :: IQSUB - INTEGER , DIMENSION(NNNW) :: JX + INTEGER , DIMENSION(NNNW) :: IOCC + INTEGER , DIMENSION(NW2) :: IQSUB + INTEGER , DIMENSION(NNNW) :: JX INTEGER :: NCORP1, NPEEL, NPEEL2, J, NPJ, NAKJ, I, LENTH, NCFD, NREC, IOS& , IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN, NJXN, NPEELN, & NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU, JSUB, IQT, NBEG, NEND, & - JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECORD*256, RECL + JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECORD*256, RECL !----------------------------------------------- ! ! ! Entry message ! - WRITE (6, *) 'Loading Configuration Symmetry List File ...' + WRITE (6, *) 'Loading Configuration Symmetry List File ...' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (21, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (21, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (21, *) - CALL PRSRSL (21, 2) - NPEEL = NW - NCORE - NPEEL2 = NPEEL*2 + READ (21, *) + CALL PRSRSL (21, 2) + NPEEL = NW - NCORE + NPEEL2 = NPEEL*2 ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE - WRITE (6, *) 'LODCSL: The lists of core and' - WRITE (6, *) ' peel subshells must form' - WRITE (6, *) ' disjoint sets.' - STOP - END DO - END DO + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + WRITE (6, *) 'LODCSL: The lists of core and' + WRITE (6, *) ' peel subshells must form' + WRITE (6, *) ' disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) ' there are '//RECORD(1:LENTH)//& - ' relativistic subshells;' - ELSE - WRITE (6, *) ' there is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) ' there is 1 relativistic subshell;' + ENDIF ! ! Initial allocation for arrays with a dimension dependent ! on the number of CSFs; the initial allocation must be ! greater than 1 ! - CALL DALLOC (IQA, 'IQA', 'LODCSLM') - CALL DALLOC (JQSA, 'JQSA', 'LODCSLM') - CALL DALLOC (JCUPA, 'JCUPA', 'LODCSLM') - NCFD = 2 - CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSLM') - CALL ALLOC (JQSA, NNNW, 3, NCFD, 'JQSA', 'LODCSLM') - CALL ALLOC (JCUPA, NNNW, NCFD, 'JCUPA', 'LODCSLM') + CALL DALLOC (IQA, 'IQA', 'LODCSLM') + CALL DALLOC (JQSA, 'JQSA', 'LODCSLM') + CALL DALLOC (JCUPA, 'JCUPA', 'LODCSLM') + NCFD = 2 + CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSLM') + CALL ALLOC (JQSA, NNNW, 3, NCFD, 'JQSA', 'LODCSLM') + CALL ALLOC (JCUPA, NNNW, NCFD, 'JCUPA', 'LODCSLM') ! ! Skip the header for the list of CSFs ! - READ (21, *) + READ (21, *) ! ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -160,400 +160,400 @@ SUBROUTINE LODCSLM(NCORE) ! These conventions have been chosen so as to render the CSF ! specifications easily interpreted by the user ! - NCF = 0 - 3 CONTINUE - NCF = NCF + 1 + NCF = 0 + 3 CONTINUE + NCF = NCF + 1 ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** !blk* ! To skip the border line added to mark the end of a block ! - IF (RECORD(1:2) == ' *') READ (21, '(A)', IOSTAT=IOS) RECORD + IF (RECORD(1:2) == ' *') READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** - - IF (IOS == 0) THEN + + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN - WRITE (6, *) 'LODCSL: Expecting subshell quantum' - WRITE (6, *) ' number specification;' - GO TO 26 - ENDIF - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN + WRITE (6, *) 'LODCSL: Expecting subshell quantum' + WRITE (6, *) ' number specification;' + GO TO 26 + ENDIF + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN - WRITE (6, *) 'LODCSL: Expecting intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum number and final parity' - WRITE (6, *) ' specification;' - GO TO 26 - ENDIF + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN + WRITE (6, *) 'LODCSL: Expecting intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum number and final parity' + WRITE (6, *) ' specification;' + GO TO 26 + ENDIF ! ! Allocate additional storage if necessary ! - IF (NCF > NCFD) THEN - NEWSIZ = NCFD + NCFD/2 + IF (NCF > NCFD) THEN + NEWSIZ = NCFD + NCFD/2 CALL RALLOC (IQA, NNNW, NEWSIZ, 'IQA', 'LODCSLM') CALL RALLOC (JQSA, NNNW, 3, NEWSIZ, 'JQSA', 'LODCSLM') CALL RALLOC (JCUPA, NNNW, NEWSIZ, 'JCUPA', 'LODCSLM') - NCFD = NEWSIZ - ENDIF + NCFD = NEWSIZ + ENDIF ! ! Zero out the arrays that store packed integers ! - IQA(:NNNW,NCF) = 0 - JQSA(:NNNW,1,NCF) = 0 - JQSA(:NNNW,2,NCF) = 0 - JQSA(:NNNW,3,NCF) = 0 - JCUPA(:NNNW,NCF) = 0 + IQA(:NNNW,NCF) = 0 + JQSA(:NNNW,1,NCF) = 0 + JQSA(:NNNW,2,NCF) = 0 + JQSA(:NNNW,3,NCF) = 0 + JCUPA(:NNNW,NCF) = 0 ! ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE - WRITE (6, *) 'LODCSL: Incorrect parity' - WRITE (6, *) ' specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 -! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE + WRITE (6, *) 'LODCSL: Incorrect parity' + WRITE (6, *) ' specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 +! + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) - WRITE (6, *) 'LODCSL: Subshell quantum numbers' - WRITE (6, *) ' specified incorrectly for' - WRITE (6, *) ' '//RECORD(1:LENTH)//NH(I)//' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN - WRITE (6, *) 'LODCSL: Too few intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) + WRITE (6, *) 'LODCSL: Subshell quantum numbers' + WRITE (6, *) ' specified incorrectly for' + WRITE (6, *) ' '//RECORD(1:LENTH)//NH(I)//' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN + WRITE (6, *) 'LODCSL: Too few intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I& - ) - WRITE (6, *) ' subshell to previous subshells' - WRITE (6, *) ' is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN - WRITE (6, *) 'LODCSL: Too many subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF -! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN - WRITE (6, *) 'LODCSL: Too many intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF -! - IF (JX(NJXN) /= JLAST) THEN - WRITE (6, *) 'LODCSL: Final angular momentum' - WRITE (6, *) ' incorrectly specified;' - GO TO 26 - ENDIF -! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (6, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF -! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) -! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN - WRITE (6, *) 'LODCSL: Inconsistency in the number' - WRITE (6, *) ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ) + WRITE (6, *) ' subshell to previous subshells' + WRITE (6, *) ' is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN + WRITE (6, *) 'LODCSL: Too many subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF +! + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN + WRITE (6, *) 'LODCSL: Too many intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF +! + IF (JX(NJXN) /= JLAST) THEN + WRITE (6, *) 'LODCSL: Final angular momentum' + WRITE (6, *) ' incorrectly specified;' + GO TO 26 + ENDIF +! + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (6, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF +! + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) +! + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN + WRITE (6, *) 'LODCSL: Inconsistency in the number' + WRITE (6, *) ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! ! print *, 'Check duplicated CSFs' - IF (NCF > 1) THEN - DO J = 1, NCF - 1 + IF (NCF > 1) THEN + DO J = 1, NCF - 1 ! print *,'j= ',j,ncf - DO I = NCORP1, NW + DO I = NCORP1, NW ! print *,i ! print *, IQ(I,J), JQS(1,I,J), JQS(2,I,J),JQS(3,I,J) ! print *, IQ(I,ncf), JQS(1,I,ncf), JQS(2,I,ncf),JQS(3,I,ncf) - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - WRITE (6, *) I - WRITE (6, *) JCUP(I,J), JCUP(I,NCF) - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (6, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + WRITE (6, *) I + WRITE (6, *) JCUP(I,J), JCUP(I,NCF) + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (6, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) - WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty' - WRITE (6, *) ' in all CSFs; eliminating this' - WRITE (6, *) ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) - CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) + WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty' + WRITE (6, *) ' in all CSFs; eliminating this' + WRITE (6, *) ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) + CALL PACK (ITEMP, II, IQA(1:NNNW,J)) + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL ! ! All done; report ! - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) ' there are '//RECORD(1:LENTH)//' relativistic CSFs;' - WRITE (6, *) ' ... load complete;' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) ' there are '//RECORD(1:LENTH)//' relativistic CSFs;' + WRITE (6, *) ' ... load complete;' ! ! Debug printout ! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF -! - RETURN -! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 - READ (21, '(A)', ERR=29, END=29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (6, *) RECORD(1:LENTH) - END DO - 29 CONTINUE - CLOSE(21) - STOP -! - END SUBROUTINE LODCSLM + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF +! + RETURN +! + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 + READ (21, '(A)', ERR=29, END=29) RECORD + LENTH = LEN_TRIM(RECORD) + WRITE (6, *) RECORD(1:LENTH) + END DO + 29 CONTINUE + CLOSE(21) + STOP +! + END SUBROUTINE LODCSLM diff --git a/src/appl/rtransition90/lodcslm_I.f90 b/src/appl/rtransition90/lodcslm_I.f90 index c53b9ee3b..6bd4dda19 100644 --- a/src/appl/rtransition90/lodcslm_I.f90 +++ b/src/appl/rtransition90/lodcslm_I.f90 @@ -1,10 +1,10 @@ - MODULE lodcslm_I + MODULE lodcslm_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcslm (NCORE) - INTEGER, INTENT(OUT) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodcslm (NCORE) + INTEGER, INTENT(OUT) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/lodrwff.f90 b/src/appl/rtransition90/lodrwff.f90 index 93b553edb..d180beff0 100644 --- a/src/appl/rtransition90/lodrwff.f90 +++ b/src/appl/rtransition90/lodrwff.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFF(NAME) + SUBROUTINE LODRWFF(NAME) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -8,13 +8,13 @@ SUBROUTINE LODRWFF(NAME) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE memory_man USE def_C @@ -28,14 +28,14 @@ SUBROUTINE LODRWFF(NAME) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: NAME*24 + CHARACTER , INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, K, NWIN, IOS, NPYFF, NAKYFF, MYFF, JJ - REAL(DOUBLE) :: CON, FKK, EYFF, PZY + INTEGER :: J, I, K, NWIN, IOS, NPYFF, NAKYFF, MYFF, JJ + REAL(DOUBLE) :: CON, FKK, EYFF, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER :: G92RWF*6 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the final state @@ -43,97 +43,97 @@ SUBROUTINE LODRWFF(NAME) ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for final state...' + WRITE (6, *) 'Loading Radial WaveFunction File for final state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=69, FILE=NAME(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFFF, NNNP, NWFF, 'PFFF', 'LODRWFF') - CALL ALLOC (QFFF, NNNP, NWFF, 'QFFF', 'LODRWFF') + CALL ALLOC (PFFF, NNNP, NWFF, 'PFFF', 'LODRWFF') + CALL ALLOC (QFFF, NNNP, NWFF, 'QFFF', 'LODRWFF') ! ! Setup: (1) Orbital arrays to zero ! (2) Array E to -1 (no orbitals estimated) ! (3) Parameters GAMMA for each orbital ! - CON = Z/C - CON = CON*CON -! - DO J = 1, NWFF - PFFF(:NNNP,J) = 0.0D00 - QFFF(:NNNP,J) = 0.0D00 -! - EFF(J) = -1.0D00 -! - K = ABS(NAKFF(J)) - IF (NPARM > 0) THEN - GAMAFF(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMAFF(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NPFF(J), NHFF(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF - ENDIF -! - END DO + CON = Z/C + CON = CON*CON +! + DO J = 1, NWFF + PFFF(:NNNP,J) = 0.0D00 + QFFF(:NNNP,J) = 0.0D00 +! + EFF(J) = -1.0D00 +! + K = ABS(NAKFF(J)) + IF (NPARM > 0) THEN + GAMAFF(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMAFF(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NPFF(J), NHFF(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF + ENDIF +! + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (69, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(69) - ENDIF - - 3 CONTINUE - READ (69, IOSTAT=IOS) NPYFF, NAKYFF, EYFF, MYFF - IF (IOS == 0) THEN - CALL ALLOC (PA, MYFF, 'PA', 'LODRWFF' ) - CALL ALLOC (QA, MYFF, 'QA', 'LODRWFF' ) - CALL ALLOC (RA, MYFF, 'RA', 'LODRWFF' ) - READ (69) PZY, (PA(I),I=1,MYFF), (QA(I),I=1,MYFF) - READ (69) (RA(I),I=1,MYFF) - - DO J = 1, NWFF + NWIN = 0 + READ (69, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(69) + ENDIF + + 3 CONTINUE + READ (69, IOSTAT=IOS) NPYFF, NAKYFF, EYFF, MYFF + IF (IOS == 0) THEN + CALL ALLOC (PA, MYFF, 'PA', 'LODRWFF' ) + CALL ALLOC (QA, MYFF, 'QA', 'LODRWFF' ) + CALL ALLOC (RA, MYFF, 'RA', 'LODRWFF' ) + READ (69) PZY, (PA(I),I=1,MYFF), (QA(I),I=1,MYFF) + READ (69) (RA(I),I=1,MYFF) + + DO J = 1, NWFF IF (.NOT.(EFF(J)<0.0D00 .AND. NPYFF==NPFF(J) .AND. NAKYFF==NAKFF(J)& - )) CYCLE - PZFF(J) = PZY - EFF(J) = EYFF - MFFF(J) = MYFF - DO JJ = 1, MFFF(J) - PFFF(JJ,J) = PA(JJ) - QFFF(JJ,J) = QA(JJ) - END DO - NWIN = NWIN + 1 - END DO - CALL DALLOC (PA, 'PA', 'LODRWFF') - CALL DALLOC (QA, 'QA', 'LODRWFF') - CALL DALLOC (RA, 'RA', 'LODRWFF') - GO TO 3 - ENDIF + )) CYCLE + PZFF(J) = PZY + EFF(J) = EYFF + MFFF(J) = MYFF + DO JJ = 1, MFFF(J) + PFFF(JJ,J) = PA(JJ) + QFFF(JJ,J) = QA(JJ) + END DO + NWIN = NWIN + 1 + END DO + CALL DALLOC (PA, 'PA', 'LODRWFF') + CALL DALLOC (QA, 'QA', 'LODRWFF') + CALL DALLOC (RA, 'RA', 'LODRWFF') + GO TO 3 + ENDIF ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWFF) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - STOP - ENDIF + IF (NWIN < NWFF) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + STOP + ENDIF ! - WRITE (6, *) ' ... load complete;' + WRITE (6, *) ' ... load complete;' ! - CLOSE(69) - - RETURN - END SUBROUTINE LODRWFF + CLOSE(69) + + RETURN + END SUBROUTINE LODRWFF diff --git a/src/appl/rtransition90/lodrwff_I.f90 b/src/appl/rtransition90/lodrwff_I.f90 index 7a125edc6..82c449a65 100644 --- a/src/appl/rtransition90/lodrwff_I.f90 +++ b/src/appl/rtransition90/lodrwff_I.f90 @@ -1,10 +1,10 @@ - MODULE lodrwff_I + MODULE lodrwff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwff (NAME) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwff (NAME) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/lodrwfi.f90 b/src/appl/rtransition90/lodrwfi.f90 index d2dd7fdee..a0794bb47 100644 --- a/src/appl/rtransition90/lodrwfi.f90 +++ b/src/appl/rtransition90/lodrwfi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFI(NAME) + SUBROUTINE LODRWFI(NAME) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -8,11 +8,11 @@ SUBROUTINE LODRWFI(NAME) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP @@ -28,109 +28,109 @@ SUBROUTINE LODRWFI(NAME) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: NAME*24 + CHARACTER , INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, K, NWIN, IOS, NPYII, NAKYII, MYII, JJ - REAL(DOUBLE) :: CON, FKK, EYII, PZY + INTEGER :: J, I, K, NWIN, IOS, NPYII, NAKYII, MYII, JJ + REAL(DOUBLE) :: CON, FKK, EYII, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER :: G92RWF*6 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the initial state ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' + WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=69, FILE=NAME(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFII, NNNP, NWII, 'PFII', 'LODRWFI') - CALL ALLOC (QFII, NNNP, NWII, 'QFII', 'LODRWFI') -! - CON = Z/C - CON = CON*CON -! - WRITE (*, *) 'NWII', NWII - DO J = 1, NWII - WRITE (*, *) NAKII(J), NPII(J), NHII(J) - PFII(:NNNP,J) = 0.0D00 - QFII(:NNNP,J) = 0.0D00 -! - EII(J) = -1.0D00 -! - K = ABS(NAKII(J)) - IF (NPARM > 0) THEN - GAMAII(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMAII(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NPII(J), NHII(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF - ENDIF -! - END DO + CALL ALLOC (PFII, NNNP, NWII, 'PFII', 'LODRWFI') + CALL ALLOC (QFII, NNNP, NWII, 'QFII', 'LODRWFI') +! + CON = Z/C + CON = CON*CON +! + WRITE (*, *) 'NWII', NWII + DO J = 1, NWII + WRITE (*, *) NAKII(J), NPII(J), NHII(J) + PFII(:NNNP,J) = 0.0D00 + QFII(:NNNP,J) = 0.0D00 +! + EII(J) = -1.0D00 +! + K = ABS(NAKII(J)) + IF (NPARM > 0) THEN + GAMAII(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMAII(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NPII(J), NHII(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF + ENDIF +! + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (69, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(69) - ENDIF - - 3 CONTINUE - READ (69, IOSTAT=IOS) NPYII, NAKYII, EYII, MYII - IF (IOS == 0) THEN - CALL ALLOC (PA, MYII, 'PA', 'LODRWFI') - CALL ALLOC (QA, MYII, 'QA', 'LODRWFI') - CALL ALLOC (RA, MYII, 'RA', 'LODRWFI') - READ (69) PZY, (PA(I),I=1,MYII), (QA(I),I=1,MYII) - READ (69) (RA(I),I=1,MYII) - - DO J = 1, NWII + NWIN = 0 + READ (69, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(69) + ENDIF + + 3 CONTINUE + READ (69, IOSTAT=IOS) NPYII, NAKYII, EYII, MYII + IF (IOS == 0) THEN + CALL ALLOC (PA, MYII, 'PA', 'LODRWFI') + CALL ALLOC (QA, MYII, 'QA', 'LODRWFI') + CALL ALLOC (RA, MYII, 'RA', 'LODRWFI') + READ (69) PZY, (PA(I),I=1,MYII), (QA(I),I=1,MYII) + READ (69) (RA(I),I=1,MYII) + + DO J = 1, NWII IF (.NOT.(EII(J)<0.0D00 .AND. NPYII==NPII(J) .AND. NAKYII==NAKII(J)& - )) CYCLE - PZII(J) = PZY - EII(J) = EYII - MFII(J) = MYII - DO JJ = 1, MFII(J) - PFII(JJ,J) = PA(JJ) - QFII(JJ,J) = QA(JJ) - END DO - NWIN = NWIN + 1 - END DO - CALL DALLOC (PA, 'PA', 'LODRWFI') - CALL DALLOC (QA, 'QA', 'LODRWFI') - CALL DALLOC (RA, 'RA', 'LODRWFI') - GO TO 3 - ENDIF + )) CYCLE + PZII(J) = PZY + EII(J) = EYII + MFII(J) = MYII + DO JJ = 1, MFII(J) + PFII(JJ,J) = PA(JJ) + QFII(JJ,J) = QA(JJ) + END DO + NWIN = NWIN + 1 + END DO + CALL DALLOC (PA, 'PA', 'LODRWFI') + CALL DALLOC (QA, 'QA', 'LODRWFI') + CALL DALLOC (RA, 'RA', 'LODRWFI') + GO TO 3 + ENDIF ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWII) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - STOP - ENDIF + IF (NWIN < NWII) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + STOP + ENDIF ! - WRITE (6, *) ' ... load complete;' + WRITE (6, *) ' ... load complete;' ! - CLOSE(69) - - RETURN - END SUBROUTINE LODRWFI + CLOSE(69) + + RETURN + END SUBROUTINE LODRWFI diff --git a/src/appl/rtransition90/lodrwfi_I.f90 b/src/appl/rtransition90/lodrwfi_I.f90 index 93bad1578..ab1327c1b 100644 --- a/src/appl/rtransition90/lodrwfi_I.f90 +++ b/src/appl/rtransition90/lodrwfi_I.f90 @@ -1,10 +1,10 @@ - MODULE lodrwfi_I + MODULE lodrwfi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwfi (NAME) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwfi (NAME) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/mctin.f90 b/src/appl/rtransition90/mctin.f90 index 99c09c9ef..4dedc0b53 100644 --- a/src/appl/rtransition90/mctin.f90 +++ b/src/appl/rtransition90/mctin.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCTIN(IOPAR, JKP, NAME) + SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! * ! This routine loads coefficients with parity and rank specified * ! by KP(JKP) into the arrays ISLDR and XSLDR. IOPAR is the parity * @@ -10,79 +10,79 @@ SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! Updated by Jacek Bieron Last revision: 10 Mar 1994 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW USE debug_C USE decide_C USE def_C USE foparm_C - USE OFFD_C + USE OFFD_C USE orb_C - USE OSC_C + USE OSC_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcnsa_I - USE alcnta_I + USE alcnsa_I + USE alcnta_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IOPAR - INTEGER, INTENT(IN) :: JKP - CHARACTER :: NAME(2)*24 + INTEGER :: IOPAR + INTEGER, INTENT(IN) :: JKP + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NFILE2, M, K, IBLKI, IBLKF, I, LABL, NCSF, J - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL - LOGICAL :: AVAIL + INTEGER :: NFILE2, M, K, IBLKI, IBLKF, I, LABL, NCSF, J + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + LOGICAL :: AVAIL !----------------------------------------------- ! ! Read the data back as required by OSCL conventions ! - NFILE2 = NFILE1 + JKP - - M = 0 - K = 0 + NFILE2 = NFILE1 + JKP + + M = 0 + K = 0 ! - READ (NFILE2) IBLKI, IBLKF, NW, NKP - READ (NFILE2) NINT + READ (NFILE2) IBLKI, IBLKF, NW, NKP + READ (NFILE2) NINT ! - DO I = 1, NINT + DO I = 1, NINT ! - READ (NFILE2) LABL, NCSF + READ (NFILE2) LABL, NCSF ! - M = M + 1 + M = M + 1 !bieron IF (M >= NSDIM) CALL ALCNSA (JJA, JJB, HB1, HB2, HC1, & - HC2, HM1, HM2, LAB, NPTR, NSDIM, 2) - LAB(M) = LABL + HC2, HM1, HM2, LAB, NPTR, NSDIM, 2) + LAB(M) = LABL ! ! Read configuration pairs and coefficients for this integral ! - 4 CONTINUE - IF (NCSF + K > NTDIM) THEN - CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 2) - GO TO 4 - ENDIF - NPTR(M) = K - READ (NFILE2) (ISLDR(J + K),ISLDR1(J + K),XSLDR(J + K),J=1,NCSF) + 4 CONTINUE + IF (NCSF + K > NTDIM) THEN + CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 2) + GO TO 4 + ENDIF + NPTR(M) = K + READ (NFILE2) (ISLDR(J + K),ISLDR1(J + K),XSLDR(J + K),J=1,NCSF) ! write(*,*) (ISLDR(J+K),XSLDR(J+K),J = 1,NCSF) - K = K + NCSF + K = K + NCSF ! - END DO + END DO ! ! Close (and hence release) the scratch file ! @@ -91,13 +91,13 @@ SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! CLOSE (unit=NFILE,status="DELETE") ! ENDIF ! - NPTR(M+1) = K - NINTEG = M + NPTR(M+1) = K + NINTEG = M ! - RETURN + RETURN ! 301 FORMAT(/,/,/,1X,I8,' MCT coefficients generated for rank ',I2,& - ' and parity ',I2,/,/) - RETURN + ' and parity ',I2,/,/) + RETURN ! - END SUBROUTINE MCTIN + END SUBROUTINE MCTIN diff --git a/src/appl/rtransition90/mctin_I.f90 b/src/appl/rtransition90/mctin_I.f90 index ebb0bbb1f..a58b1794a 100644 --- a/src/appl/rtransition90/mctin_I.f90 +++ b/src/appl/rtransition90/mctin_I.f90 @@ -1,12 +1,12 @@ - MODULE mctin_I + MODULE mctin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mctin (IOPAR, JKP, NAME) - INTEGER :: IOPAR - INTEGER, INTENT(IN) :: JKP - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mctin (IOPAR, JKP, NAME) + INTEGER :: IOPAR + INTEGER, INTENT(IN) :: JKP + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/mctout_gg.f90 b/src/appl/rtransition90/mctout_gg.f90 index 5a065cf81..5da5499a9 100644 --- a/src/appl/rtransition90/mctout_gg.f90 +++ b/src/appl/rtransition90/mctout_gg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCTOUT(IOPAR, JKP, NAME) + SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! * ! This routine loads coefficients with parity and rank specified * ! by KP(JKP) into the arrays ISLDR and XSLDR. IOPAR is the parity * @@ -10,13 +10,13 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! Updated by Jacek Bieron Last revision: 10 Mar 1994 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW USE memory_man USE blk_C @@ -24,34 +24,34 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) USE decide_C USE foparm_C USE orb_C - USE OFFD_C - USE OSC_C + USE OFFD_C + USE OSC_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE angdata_I - USE itjpo_I - USE oneparticlejj_I - USE trsort_I + USE angdata_I + USE itjpo_I + USE oneparticlejj_I + USE trsort_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IOPAR - INTEGER :: JKP - CHARACTER :: NAME(2)*24 + INTEGER :: IOPAR + INTEGER :: JKP + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NFILE2, IBLKI, IBLKF, NMCT, NLABEL, NCFI0, NCFF0, IC, IR, NCR& - , IA, IB, NEWSIZ, I - LOGICAL :: AVAIL + , IA, IB, NEWSIZ, I + LOGICAL :: AVAIL INTEGER, DIMENSION(:), pointer :: label REAL(DOUBLE), DIMENSION(:), pointer:: coeff REAL(DOUBLE), DIMENSION(NNNW) :: tshell @@ -64,28 +64,28 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! ! Check if angular data is available on file ! - NFILE2 = NFILE1 + JKP - CALL ANGDATA (NAME, AVAIL, JKP, NFILE2) - + NFILE2 = NFILE1 + JKP + CALL ANGDATA (NAME, AVAIL, JKP, NFILE2) + ! ! If angular data is not available open the scratch file to store the ! coefficients; position file ! to beginning ! ! - LK = ABS(KP(JKP)) - IOPAR = ISIGN(1,KP(JKP)) - IF (AVAIL) RETURN - WRITE (6, *) 'LK,IOPAR,from MCTOUT' - WRITE (6, *) LK, IOPAR + LK = ABS(KP(JKP)) + IOPAR = ISIGN(1,KP(JKP)) + IF (AVAIL) RETURN + WRITE (6, *) 'LK,IOPAR,from MCTOUT' + WRITE (6, *) LK, IOPAR ! ! Start of the block loops - DO IBLKI = 1, NBLOCKI - DO IBLKF = 1, NBLOCKF + DO IBLKI = 1, NBLOCKI + DO IBLKF = 1, NBLOCKF ! OPEN (NFILE,STATUS = 'new', FORM = 'UNFORMATTED') ! Sometimes, when there has been an error, status need to be "unknown" OPEN(NFILE,STATUS='unknown',FORM='UNFORMATTED') - NMCT = 0 + NMCT = 0 ! ! ! If angular data is not available @@ -95,103 +95,103 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! ! Allocate storage to buffer arrays ! - NLABEL = 32 - CALL ALLOC (LABEL, NLABEL, 'LABEL', 'MCTOUT') - CALL ALLOC (COEFF, NLABEL, 'COEFF', 'MCTOUT') - - IF (IBLKI == 1) THEN - NCFI0 = 1 - ELSE - NCFI0 = NCFI(IBLKI-1) + 1 - ENDIF -! - IF (IBLKF == 1) THEN - NCFF0 = NCFI(NBLOCKI) + 1 - ELSE - NCFF0 = NCFI(NBLOCKI) + NCFF(IBLKF-1) + 1 - ENDIF - DO IC = NCFI0, NCFI(IBLKI) - DO IR = NCFF0, NCFI(NBLOCKI) + NCFF(IBLKF) + NLABEL = 32 + CALL ALLOC (LABEL, NLABEL, 'LABEL', 'MCTOUT') + CALL ALLOC (COEFF, NLABEL, 'COEFF', 'MCTOUT') + + IF (IBLKI == 1) THEN + NCFI0 = 1 + ELSE + NCFI0 = NCFI(IBLKI-1) + 1 + ENDIF +! + IF (IBLKF == 1) THEN + NCFF0 = NCFI(NBLOCKI) + 1 + ELSE + NCFF0 = NCFI(NBLOCKI) + NCFF(IBLKF-1) + 1 + ENDIF + DO IC = NCFI0, NCFI(IBLKI) + DO IR = NCFF0, NCFI(NBLOCKI) + NCFF(IBLKF) ! ! IR = IC ! - NCR = 0 - + NCR = 0 + ! ! In many case one is interested only in M1 and E2 transitions between ! levels with different J values. If this is the case then the do check ! on the J quantum numbers of the CSFs before calling TNSRJJ. ! - IF (KP(JKP)==1 .AND. NOFFD1==1) THEN - IF (ITJPO(IC) == ITJPO(IR)) CYCLE - ENDIF - IF (KP(JKP)==2 .AND. NOFFD2==1) THEN - IF (ITJPO(IC) == ITJPO(IR)) CYCLE - ENDIF + IF (KP(JKP)==1 .AND. NOFFD1==1) THEN + IF (ITJPO(IC) == ITJPO(IR)) CYCLE + ENDIF + IF (KP(JKP)==2 .AND. NOFFD2==1) THEN + IF (ITJPO(IC) == ITJPO(IR)) CYCLE + ENDIF ! if(ispar(ic)*ispar(ir)*iopar.ne.1. ! & or.itrig(itjpo(ic),itjpo(ir),2*lk+1).ne.1) go to 13 ! if(ichkq1(IC,IR).eq.0) go to 13 CALL ONEPARTICLEJJ(LK,IOPAR,IC,IR,IA,IB,TSHELL) - IF (IA /= 0) THEN - IF (IA == IB) THEN - DO IA = 1, NW - IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE - NCR = NCR + 1 - IF (NCR > NLABEL) THEN - NEWSIZ = 2*NLABEL - CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') - CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') - NLABEL = NEWSIZ - ENDIF - LABEL(NCR) = IA*KEYORB + IA - COEFF(NCR) = TSHELL(IA) - END DO - ELSE - IF (ABS(TSHELL(1)) > CUTOFF) THEN - NCR = NCR + 1 - IF (NCR > NLABEL) THEN - NEWSIZ = 2*NLABEL - CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') - CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') - NLABEL = NEWSIZ - ENDIF - LABEL(NCR) = IA*KEYORB + IB - COEFF(NCR) = TSHELL(1) - ENDIF - ENDIF - ENDIF - IF (NCR <= 0) CYCLE - WRITE (NFILE) IC - NCFI0 + 1, IR - NCFF0 + 1, NCR + IF (IA /= 0) THEN + IF (IA == IB) THEN + DO IA = 1, NW + IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE + NCR = NCR + 1 + IF (NCR > NLABEL) THEN + NEWSIZ = 2*NLABEL + CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') + CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') + NLABEL = NEWSIZ + ENDIF + LABEL(NCR) = IA*KEYORB + IA + COEFF(NCR) = TSHELL(IA) + END DO + ELSE + IF (ABS(TSHELL(1)) > CUTOFF) THEN + NCR = NCR + 1 + IF (NCR > NLABEL) THEN + NEWSIZ = 2*NLABEL + CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') + CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') + NLABEL = NEWSIZ + ENDIF + LABEL(NCR) = IA*KEYORB + IB + COEFF(NCR) = TSHELL(1) + ENDIF + ENDIF + ENDIF + IF (NCR <= 0) CYCLE + WRITE (NFILE) IC - NCFI0 + 1, IR - NCFF0 + 1, NCR ! WRITE (NFILE) IC,IR,NCR - WRITE (NFILE) (LABEL(I),COEFF(I),I=1,NCR) - NMCT = NMCT + NCR - + WRITE (NFILE) (LABEL(I),COEFF(I),I=1,NCR) + NMCT = NMCT + NCR + ! - END DO - END DO + END DO + END DO ! ! Deallocate storage for buffer arrays ! - CALL DALLOC (LABEL, 'LABEL', 'MCTOUT') - CALL DALLOC (COEFF, 'COEFF', 'MCTOUT') + CALL DALLOC (LABEL, 'LABEL', 'MCTOUT') + CALL DALLOC (COEFF, 'COEFF', 'MCTOUT') ! - WRITE (*, 301) NMCT, LK, IOPAR + WRITE (*, 301) NMCT, LK, IOPAR ! ! Sort the MCT coefficients by integral labels ! - CALL TRSORT (NAME, NFILE, NFILE2, LDBPA(2), JKP, IBLKI, IBLKF) - CLOSE(NFILE, STATUS='delete') + CALL TRSORT (NAME, NFILE, NFILE2, LDBPA(2), JKP, IBLKI, IBLKF) + CLOSE(NFILE, STATUS='delete') ! end of the loops for blocks - END DO - END DO + END DO + END DO ! ! Read the data back as required by OSCL conventions ! - REWIND (NFILE2) - RETURN + REWIND (NFILE2) + RETURN ! 301 FORMAT(/,/,/,1X,I8,' MCT coefficients generated for rank ',I2,& - ' and parity ',I2,/,/) - RETURN + ' and parity ',I2,/,/) + RETURN ! - END SUBROUTINE MCTOUT + END SUBROUTINE MCTOUT diff --git a/src/appl/rtransition90/mctout_gg_I.f90 b/src/appl/rtransition90/mctout_gg_I.f90 index 0c399bdf5..0fdc42de5 100644 --- a/src/appl/rtransition90/mctout_gg_I.f90 +++ b/src/appl/rtransition90/mctout_gg_I.f90 @@ -1,12 +1,12 @@ - MODULE mctout_I + MODULE mctout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mctout (IOPAR, JKP, NAME) - INTEGER, INTENT(OUT) :: IOPAR - INTEGER, INTENT(IN) :: JKP - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mctout (IOPAR, JKP, NAME) + INTEGER, INTENT(OUT) :: IOPAR + INTEGER, INTENT(IN) :: JKP + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/merg12.f90 b/src/appl/rtransition90/merg12.f90 index ec06e27d5..80b5f0a00 100644 --- a/src/appl/rtransition90/merg12.f90 +++ b/src/appl/rtransition90/merg12.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MERG12(NAME, NCORER, NCORE) + SUBROUTINE MERG12(NAME, NCORER, NCORE) ! * ! This subroutines merges the initial and final state lists * ! Observ that there may doublets in this list if the initial * @@ -9,13 +9,13 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE def_C USE orb_C @@ -23,170 +23,170 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE iqr_I - USE ispar_I - USE isparr_I - USE itjpo_I - USE itjpor_I + USE iq_I + USE iqr_I + USE ispar_I + USE isparr_I + USE itjpo_I + USE itjpor_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NCORER - INTEGER , INTENT(IN) :: NCORE - CHARACTER , INTENT(IN) :: NAME(2)*24 + INTEGER , INTENT(IN) :: NCORER + INTEGER , INTENT(IN) :: NCORE + CHARACTER , INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1 - INTEGER, DIMENSION(0:NNNW + 1) :: NEWNP - INTEGER, DIMENSION(NNNW) :: NEWNAK, ICON, ICON1 - INTEGER :: I, J, ICOMP, NEW, IPI1, IPI2, K, NEW1, NEW2, M, NLINE - CHARACTER :: LINE*500 - CHARACTER, DIMENSION(NNNW) :: NEWNH*2 - CHARACTER :: NEW3*2 + INTEGER :: J1 + INTEGER, DIMENSION(0:NNNW + 1) :: NEWNP + INTEGER, DIMENSION(NNNW) :: NEWNAK, ICON, ICON1 + INTEGER :: I, J, ICOMP, NEW, IPI1, IPI2, K, NEW1, NEW2, M, NLINE + CHARACTER :: LINE*500 + CHARACTER, DIMENSION(NNNW) :: NEWNH*2 + CHARACTER :: NEW3*2 !----------------------------------------------- ! ! ! NCFI(I): the end position of the Ith block for the initial states in the globle CSF list ! NCFF(I): the end position of the Ith block for the final states in the globle CSF list - + ! OPEN(UNIT=21, FILE='SLASK', FORM='FORMATTED', STATUS='UNKNOWN', POSITION=& - 'asis') + 'asis') ! ! The same number of electrons must appear in both lists ! - IF (NELECR /= NELEC) THEN - WRITE (6, *) 'The number of electrons is not equal in the' - WRITE (6, *) ' first and second GRASP92 Configuration' - WRITE (6, *) ' symmetry list files.' - STOP - ENDIF + IF (NELECR /= NELEC) THEN + WRITE (6, *) 'The number of electrons is not equal in the' + WRITE (6, *) ' first and second GRASP92 Configuration' + WRITE (6, *) ' symmetry list files.' + STOP + ENDIF ! ! THe core orbitals must be the same ! - IF (NCORE /= NCORER) THEN - WRITE (6, *) 'The number of core orbitals must be the same' - STOP - ENDIF - - DO I = 1, NCORE - IF (NP(I)==NPR(I) .AND. NAK(I)==NAKR(I)) CYCLE - WRITE (6, *) 'The core orbitals must be the same' - STOP - END DO - - ICON(:NW) = 0 + IF (NCORE /= NCORER) THEN + WRITE (6, *) 'The number of core orbitals must be the same' + STOP + ENDIF + + DO I = 1, NCORE + IF (NP(I)==NPR(I) .AND. NAK(I)==NAKR(I)) CYCLE + WRITE (6, *) 'The core orbitals must be the same' + STOP + END DO + + ICON(:NW) = 0 ! ! For each orbital in the initial list check if there is a corresponding ! orbital in the final list. If so give the number of the corresponding ! orbital ! - DO I = 1, NW - DO J = 1, NWR - IF (NP(I)/=NPR(J) .OR. NAK(I)/=NAKR(J)) CYCLE - ICON(I) = J - END DO - END DO + DO I = 1, NW + DO J = 1, NWR + IF (NP(I)/=NPR(J) .OR. NAK(I)/=NAKR(J)) CYCLE + ICON(I) = J + END DO + END DO ! ! Check if the ordering of the initial and final state orbitals ! is consistent. The condition for this is that ICON is increasing ! - J = 0 - DO I = 1, NW - IF (ICON(I) == 0) CYCLE - J = J + 1 - ICON1(J) = ICON(I) - END DO - - ICOMP = ICON1(1) - DO I = 2, J - IF (ICON1(I) < ICOMP) THEN - WRITE (*, *) ' In merg12: ordering of the initial and final' - WRITE (*, *) ' state orbitals is inconsistent. STOP' - STOP - ELSE - ICOMP = ICON1(I) - ENDIF - END DO + J = 0 + DO I = 1, NW + IF (ICON(I) == 0) CYCLE + J = J + 1 + ICON1(J) = ICON(I) + END DO + + ICOMP = ICON1(1) + DO I = 2, J + IF (ICON1(I) < ICOMP) THEN + WRITE (*, *) ' In merg12: ordering of the initial and final' + WRITE (*, *) ' state orbitals is inconsistent. STOP' + STOP + ELSE + ICOMP = ICON1(I) + ENDIF + END DO ! ! Determine a common orbital set for the initial and final state. ! The common set must be such that the order of both the initial and ! final state sets are preserved. ! - DO I = 1, NWR - NEWNP(I) = NPR(I) - NEWNAK(I) = NAKR(I) - NEWNH(I) = NHR(I) - WRITE (*, *) NEWNP(I), NEWNH(I) - END DO + DO I = 1, NWR + NEWNP(I) = NPR(I) + NEWNAK(I) = NAKR(I) + NEWNH(I) = NHR(I) + WRITE (*, *) NEWNP(I), NEWNH(I) + END DO ! ! Add the initial state orbitals at the end ! - NEW = NWR - DO I = 1, NW - IF (ICON(I) /= 0) CYCLE - NEW = NEW + 1 - NEWNP(NEW) = NP(I) - NEWNAK(NEW) = NAK(I) - NEWNH(NEW) = NH(I) - WRITE (*, *) NEWNP(NEW), NEWNH(NEW), NEW - END DO + NEW = NWR + DO I = 1, NW + IF (ICON(I) /= 0) CYCLE + NEW = NEW + 1 + NEWNP(NEW) = NP(I) + NEWNAK(NEW) = NAK(I) + NEWNH(NEW) = NH(I) + WRITE (*, *) NEWNP(NEW), NEWNH(NEW), NEW + END DO ! ! Now sort in the orbitals at the end in the right position ! - L193: DO I = NWR + 1, NEW + L193: DO I = NWR + 1, NEW ! ! Position in initial state list ! - DO J = 1, NW - IF (NEWNP(I)/=NP(J) .OR. NEWNAK(I)/=NAK(J)) CYCLE - IPI1 = J - END DO - WRITE (*, *) 'i,ipi1', I, IPI1 - - DO J = 1, NWR - IPI2 = 0 - DO K = 1, NW - IF (NEWNP(J)/=NP(K) .OR. NEWNAK(J)/=NAK(K)) CYCLE - IPI2 = K - END DO - WRITE (*, *) 'j,ipi2', J, IPI2 - IF (IPI2 == 0) CYCLE - IF (IPI1 >= IPI2) CYCLE - NEW1 = NEWNP(I) - NEW2 = NEWNAK(I) - NEW3 = NEWNH(I) - NEWNP(I:1+J:(-1)) = NEWNP(I-1:J:(-1)) - NEWNAK(I:1+J:(-1)) = NEWNAK(I-1:J:(-1)) - NEWNH(I:1+J:(-1)) = NEWNH(I-1:J:(-1)) - NEWNP(J) = NEW1 - NEWNAK(J) = NEW2 - NEWNH(J) = NEW3 - DO M = 1, NEW - WRITE (*, *) NEWNP(M), NEWNH(M) - END DO - CYCLE L193 - END DO - END DO L193 - - NW = NEW - NP(:NW) = NEWNP(1:NW) - NAK(:NW) = NEWNAK(:NW) - NH(:NW) = NEWNH(:NW) + DO J = 1, NW + IF (NEWNP(I)/=NP(J) .OR. NEWNAK(I)/=NAK(J)) CYCLE + IPI1 = J + END DO + WRITE (*, *) 'i,ipi1', I, IPI1 + + DO J = 1, NWR + IPI2 = 0 + DO K = 1, NW + IF (NEWNP(J)/=NP(K) .OR. NEWNAK(J)/=NAK(K)) CYCLE + IPI2 = K + END DO + WRITE (*, *) 'j,ipi2', J, IPI2 + IF (IPI2 == 0) CYCLE + IF (IPI1 >= IPI2) CYCLE + NEW1 = NEWNP(I) + NEW2 = NEWNAK(I) + NEW3 = NEWNH(I) + NEWNP(I:1+J:(-1)) = NEWNP(I-1:J:(-1)) + NEWNAK(I:1+J:(-1)) = NEWNAK(I-1:J:(-1)) + NEWNH(I:1+J:(-1)) = NEWNH(I-1:J:(-1)) + NEWNP(J) = NEW1 + NEWNAK(J) = NEW2 + NEWNH(J) = NEW3 + DO M = 1, NEW + WRITE (*, *) NEWNP(M), NEWNH(M) + END DO + CYCLE L193 + END DO + END DO L193 + + NW = NEW + NP(:NW) = NEWNP(1:NW) + NAK(:NW) = NEWNAK(:NW) + NH(:NW) = NEWNH(:NW) ! ! Determine NKL and NKJ ! - DO I = 1, NW - NKJ(I) = 2*ABS(NAK(I)) - 1 - IF (NAK(I) > 0) THEN - NKL(I) = (NKJ(I)+1)/2 - ELSE - NKL(I) = (NKJ(I)-1)/2 - ENDIF - END DO + DO I = 1, NW + NKJ(I) = 2*ABS(NAK(I)) - 1 + IF (NAK(I) > 0) THEN + NKL(I) = (NKJ(I)+1)/2 + ELSE + NKL(I) = (NKJ(I)-1)/2 + ENDIF + END DO ! ! Determine the common core subshells; write out the list; ! determine the pell subshells; write out the list; these @@ -194,87 +194,87 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) ! one additional line forms the remainder of the header of ! the .csl file ! - WRITE (21, '(A)') 'Core subshells:' - WRITE (21, 301) (NP(I),NH(I),I=1,NCORE) - WRITE (21, '(A)') 'Peel subshells:' - WRITE (21, 301) (NP(I),NH(I),I=NCORE + 1,NW) - WRITE (21, '(A)') 'CSF(s):' + WRITE (21, '(A)') 'Core subshells:' + WRITE (21, 301) (NP(I),NH(I),I=1,NCORE) + WRITE (21, '(A)') 'Peel subshells:' + WRITE (21, 301) (NP(I),NH(I),I=NCORE + 1,NW) + WRITE (21, '(A)') 'CSF(s):' ! ! Now write out all CSFs in the initial and final state list ! - J = INDEX(NAME(1),' ') + J = INDEX(NAME(1),' ') OPEN(UNIT=23, FILE=NAME(1)(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') - - DO I = 1, 5 - READ (23, '(A)') LINE - END DO - - NBLOCKI = 0 - NLINE = 0 - 5 CONTINUE - READ (23, '(A)', END=98) LINE - IF (LINE(1:2) == ' *') THEN - NBLOCKI = NBLOCKI + 1 - NCFI(NBLOCKI) = NLINE/3 - ELSE - NLINE = NLINE + 1 - ENDIF - K = 500 - 10 CONTINUE - IF (LINE(K:K) == ' ') THEN - K = K - 1 - IF (K > 1) GO TO 10 - ENDIF - WRITE (21, '(A)') LINE(1:K) - GO TO 5 - 98 CONTINUE - NBLOCKI = NBLOCKI + 1 - NCFI(NBLOCKI) = NLINE/3 - CLOSE(23) - + POSITION='asis') + + DO I = 1, 5 + READ (23, '(A)') LINE + END DO + + NBLOCKI = 0 + NLINE = 0 + 5 CONTINUE + READ (23, '(A)', END=98) LINE + IF (LINE(1:2) == ' *') THEN + NBLOCKI = NBLOCKI + 1 + NCFI(NBLOCKI) = NLINE/3 + ELSE + NLINE = NLINE + 1 + ENDIF + K = 500 + 10 CONTINUE + IF (LINE(K:K) == ' ') THEN + K = K - 1 + IF (K > 1) GO TO 10 + ENDIF + WRITE (21, '(A)') LINE(1:K) + GO TO 5 + 98 CONTINUE + NBLOCKI = NBLOCKI + 1 + NCFI(NBLOCKI) = NLINE/3 + CLOSE(23) + ! zou ! if(NAME(2).EQ.NAME(1)) return ! zou - J = INDEX(NAME(2),' ') + J = INDEX(NAME(2),' ') OPEN(UNIT=23, FILE=NAME(2)(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') - - DO I = 1, 5 - READ (23, '(A)') LINE - END DO - - NBLOCKF = 0 - NLINE = 0 - 15 CONTINUE - READ (23, '(A)', END=99) LINE - IF (LINE(1:2) == ' *') THEN - NBLOCKF = NBLOCKF + 1 - NCFF(NBLOCKF) = NLINE/3 - ELSE - NLINE = NLINE + 1 - ENDIF - K = 500 - 20 CONTINUE - IF (LINE(K:K) == ' ') THEN - K = K - 1 - IF (K > 1) GO TO 20 - ENDIF - WRITE (21, '(A)') LINE(1:K) - GO TO 15 - 99 CONTINUE - NBLOCKF = NBLOCKF + 1 - NCFF(NBLOCKF) = NLINE/3 - CLOSE(23) - - CLOSE(21) + POSITION='asis') + + DO I = 1, 5 + READ (23, '(A)') LINE + END DO + + NBLOCKF = 0 + NLINE = 0 + 15 CONTINUE + READ (23, '(A)', END=99) LINE + IF (LINE(1:2) == ' *') THEN + NBLOCKF = NBLOCKF + 1 + NCFF(NBLOCKF) = NLINE/3 + ELSE + NLINE = NLINE + 1 + ENDIF + K = 500 + 20 CONTINUE + IF (LINE(K:K) == ' ') THEN + K = K - 1 + IF (K > 1) GO TO 20 + ENDIF + WRITE (21, '(A)') LINE(1:K) + GO TO 15 + 99 CONTINUE + NBLOCKF = NBLOCKF + 1 + NCFF(NBLOCKF) = NLINE/3 + CLOSE(23) + + CLOSE(21) ! - - WRITE (6, *) NBLOCKI - WRITE (6, *) (NCFI(I),I=1,NBLOCKI) - WRITE (6, *) NBLOCKF - WRITE (6, *) (NCFF(I),I=1,NBLOCKF) - 301 FORMAT(120(1X,1I2,1A2)) + + WRITE (6, *) NBLOCKI + WRITE (6, *) (NCFI(I),I=1,NBLOCKI) + WRITE (6, *) NBLOCKF + WRITE (6, *) (NCFF(I),I=1,NBLOCKF) + 301 FORMAT(120(1X,1I2,1A2)) ! - RETURN - END SUBROUTINE MERG12 + RETURN + END SUBROUTINE MERG12 diff --git a/src/appl/rtransition90/merg12_I.f90 b/src/appl/rtransition90/merg12_I.f90 index 3bfe74314..2d292bff1 100644 --- a/src/appl/rtransition90/merg12_I.f90 +++ b/src/appl/rtransition90/merg12_I.f90 @@ -1,12 +1,12 @@ - MODULE merg12_I + MODULE merg12_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE merg12 (NAME, NCORER, NCORE) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCORER - INTEGER, INTENT(IN) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE merg12 (NAME, NCORER, NCORE) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCORER + INTEGER, INTENT(IN) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/mrgcsl.f90 b/src/appl/rtransition90/mrgcsl.f90 index 3f77cc8da..2903e364c 100644 --- a/src/appl/rtransition90/mrgcsl.f90 +++ b/src/appl/rtransition90/mrgcsl.f90 @@ -1,52 +1,52 @@ !*********************************************************************** ! * - SUBROUTINE MRGCSL(NAME) + SUBROUTINE MRGCSL(NAME) ! * ! Entry routine for merging two csl lists * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE def_C, ONLY: EMN, IONCTY, NELEC, Z !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ldcsl1_I - USE ldcsl2_I - USE merg12_I + USE ldcsl1_I + USE ldcsl2_I + USE merg12_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCORER, NCORE + INTEGER :: NCORER, NCORE !----------------------------------------------- ! - - WRITE (6, *) - WRITE (6, *) 'MRGCSL: Execution begins ...' + + WRITE (6, *) + WRITE (6, *) 'MRGCSL: Execution begins ...' ! ! Load the first .csl file ! - CALL LDCSL1 (NCORER, NAME(1)) + CALL LDCSL1 (NCORER, NAME(1)) ! ! Load the second .csl file ! - CALL LDCSL2 (NCORE, NAME(2)) + CALL LDCSL2 (NCORE, NAME(2)) ! ! Merge the two .csl lists, observe that there may be doublets ! among the CSF's ! - CALL MERG12 (NAME, NCORER, NCORE) - - RETURN - END SUBROUTINE MRGCSL + CALL MERG12 (NAME, NCORER, NCORE) + + RETURN + END SUBROUTINE MRGCSL diff --git a/src/appl/rtransition90/mrgcsl_I.f90 b/src/appl/rtransition90/mrgcsl_I.f90 index 64a376817..c61634b05 100644 --- a/src/appl/rtransition90/mrgcsl_I.f90 +++ b/src/appl/rtransition90/mrgcsl_I.f90 @@ -1,10 +1,10 @@ - MODULE mrgcsl_I + MODULE mrgcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mrgcsl (NAME) - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mrgcsl (NAME) + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/oscl.f90 b/src/appl/rtransition90/oscl.f90 index 4c7ec5cda..f232be6c0 100644 --- a/src/appl/rtransition90/oscl.f90 +++ b/src/appl/rtransition90/oscl.f90 @@ -1,73 +1,73 @@ ! * - SUBROUTINE OSCL(NAME) + SUBROUTINE OSCL(NAME) ! This routine controls the main sequence of routine calls for the * ! calculation of data for transitions between multiconfiguration * ! Dirac-Fock energy levels. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE blk_C USE biorb_C USE def_C, CCMPS=>CCMS USE default_C - USE EIGV_C + USE EIGV_C USE orb_C - USE OSC_C - USE PRNT_C - USE SYMA_C - USE TITL_C - USE WAVE_C + USE OSC_C + USE PRNT_C + USE SYMA_C + USE TITL_C + USE WAVE_C USE jj2lsjbio_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cpmix_I - USE alcnsa_I - USE alcnta_I - USE connect_I - USE mctout_I - USE readmix_I - USE mctin_I - USE itrig_I - USE bessj_I - USE csfm_I - USE printa_I + USE cpmix_I + USE alcnsa_I + USE alcnta_I + USE connect_I + USE mctout_I + USE readmix_I + USE mctin_I + USE itrig_I + USE bessj_I + USE csfm_I + USE printa_I USE printals_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*4, PARAMETER :: IAU = 'Hart' - CHARACTER*4, PARAMETER :: IEV = ' eV ' - CHARACTER*4, PARAMETER :: ICM = 'Kays' - CHARACTER*4, PARAMETER :: IHZ = ' Hz ' - CHARACTER*4, PARAMETER :: IANG = ' A ' - INTEGER, PARAMETER :: NCA = 65536 - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + CHARACTER*4, PARAMETER :: IAU = 'Hart' + CHARACTER*4, PARAMETER :: IEV = ' eV ' + CHARACTER*4, PARAMETER :: ICM = 'Kays' + CHARACTER*4, PARAMETER :: IHZ = ' Hz ' + CHARACTER*4, PARAMETER :: IANG = ' A ' + INTEGER, PARAMETER :: NCA = 65536 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KKA, JKP, NFILE2, IOS, my_NELEC, NCFTOTI, NWI, & NVECSIZI, IOPAR, IBLKI, NCFTOTF, NWF,& NVECSIZF, IBLKF, NVECPR, I, M, & - IELEC, LEVII, LEVFF, ITKPO, ITEST, NLP, LINES, & + IELEC, LEVII, LEVFF, ITKPO, ITEST, NLP, LINES, & ILBL, INUM_II, INUM_FF, ICOUNT1, ICOUNT2 - REAL(DOUBLE) :: FACTOR, OMEGA, ARGU, ASFA, ASFB + REAL(DOUBLE) :: FACTOR, OMEGA, ARGU, ASFA, ASFB REAL(DOUBLE), DIMENSION(:), pointer :: et, et1, ipr, ipr1, next - LOGICAL :: AVAIL, LSAME - CHARACTER :: ANSW*1, IUNITS*4, G92MIX*6 + LOGICAL :: AVAIL, LSAME + CHARACTER :: ANSW*1, IUNITS*4, G92MIX*6 !----------------------------------------------- ! ! NCFI(I): the end position of the Ith block for the initial states in the globle CSF list @@ -75,8 +75,8 @@ SUBROUTINE OSCL(NAME) ! ! for the case that the inital file and final file are same ! - LSAME = TRIM(NAME(1)) == TRIM(NAME(2)) - IF (LSAME) CALL CPMIX (NAME, INPCI) + LSAME = TRIM(NAME(1)) == TRIM(NAME(2)) + IF (LSAME) CALL CPMIX (NAME, INPCI) ! ! write header for the result file ! @@ -90,54 +90,54 @@ SUBROUTINE OSCL(NAME) end if ! CALL ALCNSA (JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, 1) - CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 1) + HM2, LAB, NPTR, NSDIM, 1) + CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 1) ! ! Make a connection between the orbitals of the ! merged list and the initial and final state lists ! - CALL CONNECT + CALL CONNECT ! ! Set up units for printing transition energy ! - IF (LTC(1)) THEN + IF (LTC(1)) THEN ! ! Print transition energies in Angstroms ! - FACTOR = AUCM - FACTOR = 1.0D08/FACTOR - IUNITS = IANG + FACTOR = AUCM + FACTOR = 1.0D08/FACTOR + IUNITS = IANG ! - ELSE IF (LTC(2)) THEN + ELSE IF (LTC(2)) THEN ! ! Print energies in eV ! - FACTOR = AUEV - IUNITS = IEV + FACTOR = AUEV + IUNITS = IEV ! - ELSE IF (LTC(3)) THEN + ELSE IF (LTC(3)) THEN ! ! Print transition energies in Hartree Atomic Units ! - FACTOR = 1.0D00 - IUNITS = IAU + FACTOR = 1.0D00 + IUNITS = IAU ! - ELSE IF (LTC(4)) THEN + ELSE IF (LTC(4)) THEN ! ! Print transition energies in Hz ! - FACTOR = AUCM - FACTOR = FACTOR*CCMPS - IUNITS = IHZ + FACTOR = AUCM + FACTOR = FACTOR*CCMPS + IUNITS = IHZ ! - ELSE IF (LTC(5)) THEN + ELSE IF (LTC(5)) THEN ! ! Print transition energies in Kaysers ! - FACTOR = AUCM - IUNITS = ICM + FACTOR = AUCM + IUNITS = ICM ! - ENDIF + ENDIF ! ! Select type of transition ! @@ -148,62 +148,62 @@ SUBROUTINE OSCL(NAME) ! = (-1)**(N+1) Magnetic N-pole. ! N > 0 ! - KKA = 1 - DO JKP = 1, NKP - NFILE2 = NFILE1 + JKP + KKA = 1 + DO JKP = 1, NKP + NFILE2 = NFILE1 + JKP ! ! read the head of the file of mixing coef. for initial ! - IF (LSAME) NAME(1) = TRIM(NAME(2))//'_CP' - IF (INPCI == 0) THEN + IF (LSAME) NAME(1) = TRIM(NAME(2))//'_CP' + IF (INPCI == 0) THEN OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.cbm', FORM='UNFORMATTED', & - STATUS='OLD') - ELSE + STATUS='OLD') + ELSE OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.bm', FORM='UNFORMATTED', & - STATUS='OLD') - ENDIF - IF (LSAME) NAME(1) = NAME(2) - READ (68, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - READ (68) NELEC, NCFTOTI, NWI, NVECTOTI, NVECSIZI, NBLOCKI - WRITE (*, *) ' nelec = ', my_NELEC - WRITE (*, *) ' ncftoti = ', NCFTOTI - WRITE (*, *) ' nwi = ', NWI - WRITE (*, *) ' nblocki = ', NBLOCKI - WRITE (*, *) + STATUS='OLD') + ENDIF + IF (LSAME) NAME(1) = NAME(2) + READ (68, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + READ (68) NELEC, NCFTOTI, NWI, NVECTOTI, NVECSIZI, NBLOCKI + WRITE (*, *) ' nelec = ', my_NELEC + WRITE (*, *) ' ncftoti = ', NCFTOTI + WRITE (*, *) ' nwi = ', NWI + WRITE (*, *) ' nblocki = ', NBLOCKI + WRITE (*, *) ! lbl ICOUNT1 = 0 - CALL LDLBL1 (NAME(1)) + CALL LDLBL1 (NAME(1)) ! If not available generate angular coefficients for all pares of blocks - CALL MCTOUT (IOPAR, JKP, NAME) - DO IBLKI = 1, NBLOCKI - CALL READMIX (NAME, INPCI, 1) + CALL MCTOUT (IOPAR, JKP, NAME) + DO IBLKI = 1, NBLOCKI + CALL READMIX (NAME, INPCI, 1) ! lbl ICOUNT1 = NVECII + ICOUNT1 ! ! read the head of the file of mixing coef. for final ! - IF (INPCI == 0) THEN + IF (INPCI == 0) THEN OPEN(UNIT=78,FILE=TRIM(NAME(2))//'.cbm', & - FORM='UNFORMATTED',STATUS='OLD') - ELSE + FORM='UNFORMATTED',STATUS='OLD') + ELSE OPEN(UNIT=78, FILE=TRIM(NAME(2))//'.bm', & - FORM='UNFORMATTED',STATUS='OLD') - ENDIF - READ (78, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - READ (78) NELEC, NCFTOTF, NWF, NVECTOTF, NVECSIZF, NBLOCKF - WRITE (*, *) ' nelec = ', my_NELEC - WRITE (*, *) ' ncftotf = ', NCFTOTF - WRITE (*, *) ' nwf = ', NWF - WRITE (*, *) ' nblockf = ', NBLOCKF - WRITE (*, *) + FORM='UNFORMATTED',STATUS='OLD') + ENDIF + READ (78, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + READ (78) NELEC, NCFTOTF, NWF, NVECTOTF, NVECSIZF, NBLOCKF + WRITE (*, *) ' nelec = ', my_NELEC + WRITE (*, *) ' ncftotf = ', NCFTOTF + WRITE (*, *) ' nwf = ', NWF + WRITE (*, *) ' nblockf = ', NBLOCKF + WRITE (*, *) !GG lbl IF(IBLKI .EQ. 1) THEN CALL LDLBL2 (NAME(2)) @@ -216,160 +216,160 @@ SUBROUTINE OSCL(NAME) END IF END IF ICOUNT2 = 0 -!GG lbl end - DO IBLKF = 1, NBLOCKF - CALL READMIX (NAME, INPCI, 2) +!GG lbl end + DO IBLKF = 1, NBLOCKF + CALL READMIX (NAME, INPCI, 2) ! lbl ICOUNT2 = NVECFF + ICOUNT2 ! ! Allocate storage ! - CALL ALLOC (TOTB, NVECFF, 'TOTB', 'OSCL') - CALL ALLOC (TOTC, NVECFF, 'TOTC', 'OSCL') + CALL ALLOC (TOTB, NVECFF, 'TOTB', 'OSCL') + CALL ALLOC (TOTC, NVECFF, 'TOTC', 'OSCL') ! - NVECPR = NVECII*NVECFF - CALL ALLOC (ET, NVECPR, 'ET', 'OSCL' ) - CALL ALLOC (ET1, NVECPR, 'ET1','OSCL' ) - CALL ALLOC (IPR, NVECPR, 'IPR', 'OSCL' ) - CALL ALLOC (IPR1, NVECPR,'IPR1', 'OSCL' ) - CALL ALLOC (NEXT, NVECPR, 'NEXT', 'OSCL') + NVECPR = NVECII*NVECFF + CALL ALLOC (ET, NVECPR, 'ET', 'OSCL' ) + CALL ALLOC (ET1, NVECPR, 'ET1','OSCL' ) + CALL ALLOC (IPR, NVECPR, 'IPR', 'OSCL' ) + CALL ALLOC (IPR1, NVECPR,'IPR1', 'OSCL' ) + CALL ALLOC (NEXT, NVECPR, 'NEXT', 'OSCL') ! ! Initialization for total decay rate ! - TOTC(:NVECFF) = 0.0D00 - TOTB(:NVECFF) = 0.0D00 + TOTC(:NVECFF) = 0.0D00 + TOTB(:NVECFF) = 0.0D00 ! - CALL MCTIN (IOPAR, JKP, NAME) + CALL MCTIN (IOPAR, JKP, NAME) ! - IF (LK > 0) THEN - IELEC = (-1)**LK - IF (IELEC == IOPAR) THEN - KK = 0 - KKA = 0 - ELSE - KK = 1 - IELEC = -IELEC - ENDIF + IF (LK > 0) THEN + IELEC = (-1)**LK + IF (IELEC == IOPAR) THEN + KK = 0 + KKA = 0 + ELSE + KK = 1 + IELEC = -IELEC + ENDIF ! ! Set up list of levels for calculation of oscillator strengths ! sort list into increasing order of energy if option 6 set ! - IF (IBLKI==1 .AND. IBLKF==1) THEN - IF (KK == 0) THEN - WRITE (24, 308) LK - ELSE - WRITE (24, 309) LK - ENDIF - WRITE (24, 310) - IF (LTC(1)) THEN - WRITE (24, 311) - IF (.NOT.LTC(7)) THEN - WRITE (24, 312) - ELSE - WRITE (24, 313) - ENDIF - ELSE - WRITE (24, 314) - IF (.NOT.LTC(7)) THEN - WRITE (24, 315) IUNITS - ELSE - WRITE (24, 316) IUNITS - ENDIF - ENDIF - ENDIF -! - DO LEVII = 1, NVECII + IF (IBLKI==1 .AND. IBLKF==1) THEN + IF (KK == 0) THEN + WRITE (24, 308) LK + ELSE + WRITE (24, 309) LK + ENDIF + WRITE (24, 310) + IF (LTC(1)) THEN + WRITE (24, 311) + IF (.NOT.LTC(7)) THEN + WRITE (24, 312) + ELSE + WRITE (24, 313) + ENDIF + ELSE + WRITE (24, 314) + IF (.NOT.LTC(7)) THEN + WRITE (24, 315) IUNITS + ELSE + WRITE (24, 316) IUNITS + ENDIF + ENDIF + ENDIF +! + DO LEVII = 1, NVECII ! lbl INUM_II = ICOUNT1 - NVECII + LEVII - DO LEVFF = 1, NVECFF + DO LEVFF = 1, NVECFF ! lbl INUM_FF = ICOUNT2 - NVECFF + LEVFF ! ! Check for consistent parity and J ! - ITKPO = LK + LK + 1 + ITKPO = LK + LK + 1 IF (ITRIG(IATJPOII(LEVII),IATJPOFF(LEVFF),ITKPO) == 0) & - CYCLE - ITEST = IASPARII(LEVII)*IASPARFF(LEVFF)*IELEC - IF (ITEST < 0) CYCLE + CYCLE + ITEST = IASPARII(LEVII)*IASPARFF(LEVFF)*IELEC + IF (ITEST < 0) CYCLE ! ! Calculate and print transition probability data ! - NLP = 70 - 8 - LINES = NLP + NLP = 70 - 8 + LINES = NLP ! - IF (LINES >= NLP) LINES = 0 + IF (LINES >= NLP) LINES = 0 ! - M = LEVFF + NVECFF*(LEVII - 1) + M = LEVFF + NVECFF*(LEVII - 1) ! M = LEVFF+NVECII*(LEVII-1) - ET(M) = EVALFF(LEVFF) + EAVFF - EVALII(LEVII) - EAVII - IF (LSAME .AND. ET(M)<=0.0) CYCLE - OMEGA = -ET(M) - ARGU = OMEGA/C - CALL BESSJ (ARGU) + ET(M) = EVALFF(LEVFF) + EAVFF - EVALII(LEVII) - EAVII + IF (LSAME .AND. ET(M)<=0.0) CYCLE + OMEGA = -ET(M) + ARGU = OMEGA/C + CALL BESSJ (ARGU) ! ! Calculate oscillator strength between the ASFs ! - CALL CSFM (ASFA, ASFB, LEVII, LEVFF) + CALL CSFM (ASFA, ASFB, LEVII, LEVFF) CALL PRINTA (ASFA, ASFB, LEVII, LEVFF, OMEGA, FACTOR, & - LINES,LSAME) + LINES,LSAME) IF(IOPEN_STATUS1.EQ.0 .AND. IOPEN_STATUS2 .EQ.0) THEN CALL PRINTALS (INUM_II, INUM_FF,ASFA,ASFB,LEVII,LEVFF,& OMEGA,FACTOR) END IF ! WRITE (24,317) - END DO - END DO - ENDIF + END DO + END DO + ENDIF ! ! Deallocate storage; this is local to OSCL ! - CALL DALLOC (TOTB, 'TOTB', 'OSCL') - CALL DALLOC (TOTC, 'TOTC', 'OSCL') + CALL DALLOC (TOTB, 'TOTB', 'OSCL') + CALL DALLOC (TOTC, 'TOTC', 'OSCL') ! - CALL DALLOC (ET, 'ET', 'OSCL') - CALL DALLOC (ET1, 'ET!', 'OSCL') - CALL DALLOC (IPR, 'IPR', 'OSCL') - CALL DALLOC (IPR1, 'IPR1', 'OSCL') - CALL DALLOC (NEXT, 'NEXT', 'OSCL') + CALL DALLOC (ET, 'ET', 'OSCL') + CALL DALLOC (ET1, 'ET!', 'OSCL') + CALL DALLOC (IPR, 'IPR', 'OSCL') + CALL DALLOC (IPR1, 'IPR1', 'OSCL') + CALL DALLOC (NEXT, 'NEXT', 'OSCL') ! ! Deallocate storage; this is allocated in READMIX ! - CALL DALLOC (EVALFF, 'EVALFF', 'OSCL') - CALL DALLOC (EVECFF, 'EVECFF', 'OSCL') - CALL DALLOC (IVECFF, 'IVECFF', 'OSCL') - CALL DALLOC (IATJPOFF, 'IATJPOFF', 'OSCL') - CALL DALLOC (IASPARFF, 'IASPARFF', 'OSCL') - - END DO - CLOSE(78) + CALL DALLOC (EVALFF, 'EVALFF', 'OSCL') + CALL DALLOC (EVECFF, 'EVECFF', 'OSCL') + CALL DALLOC (IVECFF, 'IVECFF', 'OSCL') + CALL DALLOC (IATJPOFF, 'IATJPOFF', 'OSCL') + CALL DALLOC (IASPARFF, 'IASPARFF', 'OSCL') + + END DO + CLOSE(78) ! ! Deallocate storage; this is allocated in READMIX ! - CALL DALLOC (EVALII, 'EVALII', 'OSCL') - CALL DALLOC (EVECII, 'EVECII', 'OSCL') - CALL DALLOC (IVECII, 'IVECII', 'OSCL') - CALL DALLOC (IATJPOII, 'IATJPOII', 'OSCL') - CALL DALLOC (IASPARII, 'IASPARII', 'OSCL') - - END DO - CLOSE(68) - CLOSE(NFILE2) - END DO - CALL DALLOC (KP, 'KP', 'OSCL') + CALL DALLOC (EVALII, 'EVALII', 'OSCL') + CALL DALLOC (EVECII, 'EVECII', 'OSCL') + CALL DALLOC (IVECII, 'IVECII', 'OSCL') + CALL DALLOC (IATJPOII, 'IATJPOII', 'OSCL') + CALL DALLOC (IASPARII, 'IASPARII', 'OSCL') + + END DO + CLOSE(68) + CLOSE(NFILE2) + END DO + CALL DALLOC (KP, 'KP', 'OSCL') ! ! close and delete duplicated mixing file - IF (LSAME) THEN - IF (INPCI == 0) THEN -!GG OPEN(68, FILE=TRIM(NAME(2))//'_CP.cbm', POSITION='asis') - OPEN(68, FILE=TRIM(NAME(2))//'_CP.cbm') - ELSE -!GG OPEN(68, FILE=TRIM(NAME(2))//'_CP.bm', POSITION='asis') - OPEN(68, FILE=TRIM(NAME(2))//'_CP.bm') - ENDIF - CLOSE(68, STATUS='delete') - ENDIF + IF (LSAME) THEN + IF (INPCI == 0) THEN +!GG OPEN(68, FILE=TRIM(NAME(2))//'_CP.cbm', POSITION='asis') + OPEN(68, FILE=TRIM(NAME(2))//'_CP.cbm') + ELSE +!GG OPEN(68, FILE=TRIM(NAME(2))//'_CP.bm', POSITION='asis') + OPEN(68, FILE=TRIM(NAME(2))//'_CP.bm') + ENDIF + CLOSE(68, STATUS='delete') + ENDIF ! CALL ALCNSA (jja, jjb, hb1, hb2, hc1, hc2, hm1, hm2, lab, nptr, nsdim, 3) CALL ALCNTA (isldr, isldr1, xsldr, ntdim, 3) @@ -377,34 +377,34 @@ SUBROUTINE OSCL(NAME) ! ! Close all files ! - CLOSE(24) + CLOSE(24) ! - RETURN + RETURN ! - 302 FORMAT(/,' ***** Warning *****') - 303 FORMAT(/,/,' ***** Error in OSCL *****') - 307 FORMAT(/,' Dynamic allocation computed incorrectly: Bug.') - 308 FORMAT(/,/,' Electric 2**(',I2,')-pole transitions') - 309 FORMAT(/,/,' Magnetic 2**(',I2,')-pole transitions') - 310 FORMAT(1X,33('=')) + 302 FORMAT(/,' ***** Warning *****') + 303 FORMAT(/,/,' ***** Error in OSCL *****') + 307 FORMAT(/,' Dynamic allocation computed incorrectly: Bug.') + 308 FORMAT(/,/,' Electric 2**(',I2,')-pole transitions') + 309 FORMAT(/,/,' Magnetic 2**(',I2,')-pole transitions') + 310 FORMAT(1X,33('=')) 311 FORMAT(/,' Upper state Lower state ',8X,'Gauge',8X,'Wavelength'& - ,13X,'Einstein coefficients',13X,'Oscillator') + ,13X,'Einstein coefficients',13X,'Oscillator') 312 FORMAT(81X,'-1',15X,'3 -2 -1',/,' Level J Parity',4X,'Level J ',& 'Parity',21X,'(Angstroms)',10X,'A (s )',9X,'gB (m s J )',7X,& - 'strength gf'/) + 'strength gf'/) 313 FORMAT(' Level J Parity',4X,'Level J Parity',21X,'(Angstroms)',10X,& - 'A (au)',13X,'gB (au)',10X,'strength gf'/) - 314 FORMAT(/,' Upper Lower ') + 'A (au)',13X,'gB (au)',10X,'strength gf'/) + 314 FORMAT(/,' Upper Lower ') 315 FORMAT(' Lev J P',3X,'Lev J P',7X,'E (',A4,')',9X,'A (s-1)',10X,'gf',& - 12X,'S') + 12X,'S') 316 FORMAT(' Level J Parity',4X,'Level J Parity',23X,'(',A4,')',13X,& - 'A (au)',13X,'gB (au)',10X,'strength gf'/) - 317 FORMAT(/,1X,124('+')) + 'A (au)',13X,'gB (au)',10X,'strength gf'/) + 317 FORMAT(/,1X,124('+')) 318 FORMAT(/,/,' Radiative lifetimes '/,' ======================='/,/,& - ' Level Lifetime s (-1)') - 319 FORMAT(1X,I4,6X,'Coulomb: ',1P,1D20.7) - 320 FORMAT(10X,'Babushkin:',1P,1D20.7,/) - 321 FORMAT(1X,I4,5X,'Magnetic: ',1P,1D20.7,/) - RETURN + ' Level Lifetime s (-1)') + 319 FORMAT(1X,I4,6X,'Coulomb: ',1P,1D20.7) + 320 FORMAT(10X,'Babushkin:',1P,1D20.7,/) + 321 FORMAT(1X,I4,5X,'Magnetic: ',1P,1D20.7,/) + RETURN ! - END SUBROUTINE OSCL + END SUBROUTINE OSCL diff --git a/src/appl/rtransition90/oscl_I.f90 b/src/appl/rtransition90/oscl_I.f90 index 95a37a2d7..c762b9d01 100644 --- a/src/appl/rtransition90/oscl_I.f90 +++ b/src/appl/rtransition90/oscl_I.f90 @@ -1,10 +1,10 @@ - MODULE oscl_I + MODULE oscl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE oscl (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE oscl (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/printa.f90 b/src/appl/rtransition90/printa.f90 index b40be2540..5975e7f1e 100644 --- a/src/appl/rtransition90/printa.f90 +++ b/src/appl/rtransition90/printa.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) + SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! * ! This routine prints the basic oscillator strength information * ! for transitions between level I and level J. * @@ -8,19 +8,19 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C - USE CUTO_C + USE CUTO_C USE JLABL_C, LABJ=>JLBR, LABP=> JLBP USE OSC_C - USE SYMA_C - USE PRNT_C + USE SYMA_C + USE PRNT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -29,18 +29,18 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! D u m m y A r g u m e n t s !----------------------------------------------- LOGICAL, INTENT(IN) :: LSAME - INTEGER :: I, J - INTEGER, INTENT(INOUT) :: LINES - REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB - REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR + INTEGER :: I, J + INTEGER, INTENT(INOUT) :: LINES + REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB + REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IPAR, JPAR, ISIGNA, ISIGNB - REAL(DOUBLE), DIMENSION(10) :: DBLFAC + INTEGER :: IPAR, JPAR, ISIGNA, ISIGNB + REAL(DOUBLE), DIMENSION(10) :: DBLFAC REAL(DOUBLE) :: STFAC, DLL1, OMC, FAAU, FOSC, FBAU, ENG, GGFACTOR, & - ACSQ, ABSQ, AC, AB, BC, BB, OSCC, OSCB, SA, SB, AMS, AM, BM, OSCM - CHARACTER(LEN=4) :: JLABI, JLABJ, JPARI, JPARJ + ACSQ, ABSQ, AC, AB, BC, BB, OSCC, OSCB, SA, SB, AMS, AM, BM, OSCM + CHARACTER(LEN=4) :: JLABI, JLABJ, JPARI, JPARJ CHARACTER(LEN=2) :: F1,F2 !----------------------------------------------- ! @@ -49,83 +49,83 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! DATA DBLFAC/ 3.0000000000D00, 1.5000000000D01, 1.0500000000D02, & 9.4500000000D02, 1.0395000000D04, 1.3513500000D05, 2.0270250000D06, & - 3.4459425000D07, 6.5472907500D08, 1.3749310575D10/ + 3.4459425000D07, 6.5472907500D08, 1.3749310575D10/ ! ! Evaluate statistical factors and constants ! - STFAC = IATJPOII(I) - DLL1 = DBLE(LK + LK + 1) - STFAC = STFAC/DLL1 + STFAC = IATJPOII(I) + DLL1 = DBLE(LK + LK + 1) + STFAC = STFAC/DLL1 ! - OMC = OMEGA/CVAC + OMC = OMEGA/CVAC ! OMC = OMEGA/C - FAAU = 2.0D00*OMC*STFAC/DBLE(IATJPOFF(J)) - FOSC = CVAC*STFAC/OMC + FAAU = 2.0D00*OMC*STFAC/DBLE(IATJPOFF(J)) + FOSC = CVAC*STFAC/OMC ! FOSC = C*STFAC/OMC - FBAU = PI*FOSC/OMEGA - ENG = OMEGA*FACTOR - IF (LTC(1)) ENG = FACTOR/OMEGA + FBAU = PI*FOSC/OMEGA + ENG = OMEGA*FACTOR + IF (LTC(1)) ENG = FACTOR/OMEGA ! ! J/pi labels for levels ! - JLABI = LABJ(IATJPOII(I)) - JLABJ = LABJ(IATJPOFF(J)) - IPAR = (IASPARII(I) + 3)/2 - JPAR = (IASPARFF(J) + 3)/2 - JPARI = LABP(IPAR) - JPARJ = LABP(JPAR) + JLABI = LABJ(IATJPOII(I)) + JLABJ = LABJ(IATJPOFF(J)) + IPAR = (IASPARII(I) + 3)/2 + JPAR = (IASPARFF(J) + 3)/2 + JPARI = LABP(IPAR) + JPARJ = LABP(JPAR) !GG GGFACTOR = CVAC**(2*LK - 2)*DBLE(LK)*DBLFAC(LK)**2/((2.0D00*DBLE(LK) + & - 1.0D00)*(DBLE(LK) + 1.0D00)*ABS(OMEGA)**(2*LK - 1)) + 1.0D00)*(DBLE(LK) + 1.0D00)*ABS(OMEGA)**(2*LK - 1)) !GG-end ! ! Calculate Einstein A and B coefficients and oscillator strengths ! - IF (KK == 0) THEN + IF (KK == 0) THEN ! ! Electric multipoles ! ! In atomic units ! - IF (ASFA < 0) THEN - ISIGNA = -1 - ELSE - ISIGNA = 1 - ENDIF - IF (ASFB < 0) THEN - ISIGNB = -1 - ELSE - ISIGNB = 1 - ENDIF - - ACSQ = ASFA**2 - ABSQ = ASFB**2 - AC = ACSQ*FAAU - AB = ABSQ*FAAU - BC = ACSQ*FBAU - BB = ABSQ*FBAU - OSCC = ACSQ*FOSC - OSCB = ABSQ*FOSC - SA = OSCC*GGFACTOR - SB = OSCB*GGFACTOR + IF (ASFA < 0) THEN + ISIGNA = -1 + ELSE + ISIGNA = 1 + ENDIF + IF (ASFB < 0) THEN + ISIGNB = -1 + ELSE + ISIGNB = 1 + ENDIF + + ACSQ = ASFA**2 + ABSQ = ASFB**2 + AC = ACSQ*FAAU + AB = ABSQ*FAAU + BC = ACSQ*FBAU + BB = ABSQ*FBAU + OSCC = ACSQ*FOSC + OSCB = ABSQ*FOSC + SA = OSCC*GGFACTOR + SB = OSCB*GGFACTOR ! ! Convert to SI units if option 5 not set ! - IF (.NOT.LTC(7)) THEN - AC = AC*FASI - AB = AB*FASI - BC = BC*FBSI - BB = BB*FBSI - ENDIF + IF (.NOT.LTC(7)) THEN + AC = AC*FASI + AB = AB*FASI + BC = BC*FBSI + BB = BB*FBSI + ENDIF ! ! Accumulate total of A coefficients ! - TOTC(J) = TOTC(J) + AC - TOTB(J) = TOTB(J) + AB + TOTC(J) = TOTC(J) + AC + TOTB(J) = TOTB(J) + AB ! ! Print information if both AC and AB are greater than CUTOFF ! - IF (ABS(AC)>=CUTOFF .AND. ABS(AB)>=CUTOFF) THEN + IF (ABS(AC)>=CUTOFF .AND. ABS(AB)>=CUTOFF) THEN IF (-1.d+9 < ENG .and. ENG .LT. -1.0d-2) THEN IF (LSAME) THEN F1 = 'f ' @@ -136,8 +136,8 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) END IF ! WRITE (24, 300) F1,IVECFF(J),JLABJ,JPARJ,F2,IVECII(I),JLABI,JPARI, & - -ENG, -AC, -OSCC, -SA !, ASFA - WRITE (24, 301) -AB, -OSCB, -SB !, ASFB + -ENG, -AC, -OSCC, -SA !, ASFA + WRITE (24, 301) -AB, -OSCB, -SB !, ASFB ELSE IF ( 1.d+9 .GT. ENG .AND. ENG .GT. 1.D-2) THEN IF (LSAME) THEN F1 = 'f ' @@ -151,42 +151,42 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) OSCC,SA WRITE (24,301) AB*IATJPOFF(J)/IATJPOII(I),OSCB,SB END IF - LINES = LINES + 3 - ENDIF + LINES = LINES + 3 + ENDIF ! - ELSE + ELSE ! ! Magnetic multipoles ! ! In atomic units ! - IF (ASFA < 0) THEN - ISIGNA = -1 - ELSE - ISIGNA = 1 - ENDIF - AMS = ASFA**2 - AM = AMS*FAAU - BM = AMS*FBAU - OSCM = AMS*FOSC - SA = OSCM*GGFACTOR*CVAC*CVAC*4 + IF (ASFA < 0) THEN + ISIGNA = -1 + ELSE + ISIGNA = 1 + ENDIF + AMS = ASFA**2 + AM = AMS*FAAU + BM = AMS*FBAU + OSCM = AMS*FOSC + SA = OSCM*GGFACTOR*CVAC*CVAC*4 !GG-end ! ! Convert to SI units if option 5 not set ! - IF (.NOT.LTC(7)) THEN - AM = AM*FASI - BM = AM*FBSI - ENDIF + IF (.NOT.LTC(7)) THEN + AM = AM*FASI + BM = AM*FBSI + ENDIF ! ! Accumulate total of A coefficients ! - TOTC(J) = TOTC(J) + AM - TOTB(J) = TOTB(J) + AM + TOTC(J) = TOTC(J) + AM + TOTB(J) = TOTB(J) + AM ! ! Print information if AM is greater than CUTOFF ! - IF (ABS(AM) >= CUTOFF) THEN + IF (ABS(AM) >= CUTOFF) THEN IF (-1.d+9 < ENG .and. ENG .LT. -1.0d-2) THEN IF (LSAME) THEN F1 = 'f ' @@ -215,9 +215,9 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) LINES = LINES+2 ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! !cjb format for highly charged ions F11.2 -> F13.2 300 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,0P,F13.2,' C',1P, & @@ -226,6 +226,6 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) !cjb format for highly charged ions F11.2 -> F13.2 302 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,0P,F13.2,' M',1P, & 3D13.5) - RETURN + RETURN ! - END SUBROUTINE PRINTA + END SUBROUTINE PRINTA diff --git a/src/appl/rtransition90/printaLS.f90 b/src/appl/rtransition90/printaLS.f90 index 68524a2fb..d00c86b37 100644 --- a/src/appl/rtransition90/printaLS.f90 +++ b/src/appl/rtransition90/printaLS.f90 @@ -9,10 +9,10 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE def_C @@ -52,7 +52,7 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) print*, ' ' print*, ' INCORRECT INPUT, PROGRAM STOP!!! ' print*, ' ' - print*, ' lsj.lbl files from the jj2lsj runs are inconsistent ' + print*, ' lsj.lbl files from the jj2lsj runs are inconsistent ' print*, ' with the files used in the bioscl calculation. ' print*, ' The bioscl calculation was for rci wave functions ' print*, ' but the jj2lsj run was for rscf wave functions or ' @@ -67,8 +67,8 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) print*, ' Then rerun rtransition. ' STOP END IF - DD = D*AUCM - ANGS = 1.0D08 / DD + DD = D*AUCM + ANGS = 1.0D08 / DD ANGSA = ANGS IF(ANGS .GT. 2000.D0) THEN SIGMA = (1.D8/ANGS)**2 @@ -268,7 +268,7 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) END IF WRITE (32,40) DD,ANGS,ANGSA, & IM,LK,SA,OSCM,AM*IATJPOFF(J)/IATJPOII(I) - END IF + END IF ENDIF ENDIF RETURN diff --git a/src/appl/rtransition90/printaLS_I.f90 b/src/appl/rtransition90/printaLS_I.f90 index 157d1ea8c..ac2b51bb0 100644 --- a/src/appl/rtransition90/printaLS_I.f90 +++ b/src/appl/rtransition90/printaLS_I.f90 @@ -1,12 +1,12 @@ - MODULE printaLS_I + MODULE printaLS_I INTERFACE SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - USE vast_kind_param,ONLY: DOUBLE + USE vast_kind_param,ONLY: DOUBLE INTEGER :: I, J, INUM_II, INUM_FF REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/printa_I.f90 b/src/appl/rtransition90/printa_I.f90 index 00e3a7a26..01bdf0cdb 100644 --- a/src/appl/rtransition90/printa_I.f90 +++ b/src/appl/rtransition90/printa_I.f90 @@ -1,18 +1,18 @@ - MODULE printa_I + MODULE printa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE printa (ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE printa (ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) + USE vast_kind_param,ONLY: DOUBLE LOGICAL, INTENT(IN) :: LSAME - REAL(DOUBLE), INTENT(IN) :: ASFA - REAL(DOUBLE), INTENT(IN) :: ASFB - INTEGER :: I - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(IN) :: OMEGA - REAL(DOUBLE), INTENT(IN) :: FACTOR - INTEGER, INTENT(INOUT) :: LINES - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: ASFA + REAL(DOUBLE), INTENT(IN) :: ASFB + INTEGER :: I + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(IN) :: OMEGA + REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(INOUT) :: LINES + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/readmix.f90 b/src/appl/rtransition90/readmix.f90 index 478f0f8b1..06136040a 100644 --- a/src/appl/rtransition90/readmix.f90 +++ b/src/appl/rtransition90/readmix.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE READMIX(NAME, INPCI, INIT) + SUBROUTINE READMIX(NAME, INPCI, INIT) ! * ! Open and read the mixing coefficent files * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE biorb_C USE def_C @@ -28,57 +28,57 @@ SUBROUTINE READMIX(NAME, INPCI, INIT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: INPCI - INTEGER , INTENT(IN) :: INIT - CHARACTER :: NAME(2)*24 + INTEGER :: INPCI + INTEGER , INTENT(IN) :: INIT + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IB, IATJP, IASPA, I, J - CHARACTER :: G92MIX*6 + INTEGER :: IB, IATJP, IASPA, I, J + CHARACTER :: G92MIX*6 !----------------------------------------------- ! - IF (INIT == 1) THEN + IF (INIT == 1) THEN ! ! Read the initial state mixing file ! - READ (68) IB, NCFII, NVECII, IATJP, IASPA - CALL ALLOC (EVALII, NVECII, 'EVALII', 'READMIX') - CALL ALLOC (EVECII, NCFII*NVECII, 'EVECII', 'READMIX') - CALL ALLOC (IVECII, NVECII,'IVECII', 'READMIX' ) - CALL ALLOC (IATJPOII, NVECII, 'IATJPOII', 'READMIX') - CALL ALLOC (IASPARII, NVECII, 'ISPARII', 'READMIX') - READ (68) (IVECII(I),I=1,NVECII) - IATJPOII(:NVECII) = IATJP - IASPARII(:NVECII) = IASPA - READ (68) EAVII, (EVALII(I),I=1,NVECII) - - READ (68) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) + READ (68) IB, NCFII, NVECII, IATJP, IASPA + CALL ALLOC (EVALII, NVECII, 'EVALII', 'READMIX') + CALL ALLOC (EVECII, NCFII*NVECII, 'EVECII', 'READMIX') + CALL ALLOC (IVECII, NVECII,'IVECII', 'READMIX' ) + CALL ALLOC (IATJPOII, NVECII, 'IATJPOII', 'READMIX') + CALL ALLOC (IASPARII, NVECII, 'ISPARII', 'READMIX') + READ (68) (IVECII(I),I=1,NVECII) + IATJPOII(:NVECII) = IATJP + IASPARII(:NVECII) = IASPA + READ (68) EAVII, (EVALII(I),I=1,NVECII) + + READ (68) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) ! ! CLOSE(68) ! - ELSE + ELSE ! ! Read the final state mixing file ! - - READ (78) IB, NCFFF, NVECFF, IATJP, IASPA - CALL ALLOC (EVALFF, NVECFF, 'EVALFF', 'READMIX') - CALL ALLOC (EVECFF, NCFFF*NVECFF, 'EVECFF', 'READMIX') - CALL ALLOC (IVECFF, NVECFF,'IVECFF', 'READMIX' ) - CALL ALLOC (IATJPOFF, NVECFF, 'IATJPOFF', 'READMIX') - CALL ALLOC (IASPARFF, NVECFF, 'ISPARFF', 'READMIX') - READ (78) (IVECFF(I),I=1,NVECFF) - IATJPOFF(:NVECFF) = IATJP - IASPARFF(:NVECFF) = IASPA - READ (78) EAVFF, (EVALFF(I),I=1,NVECFF) - - READ (78) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) + + READ (78) IB, NCFFF, NVECFF, IATJP, IASPA + CALL ALLOC (EVALFF, NVECFF, 'EVALFF', 'READMIX') + CALL ALLOC (EVECFF, NCFFF*NVECFF, 'EVECFF', 'READMIX') + CALL ALLOC (IVECFF, NVECFF,'IVECFF', 'READMIX' ) + CALL ALLOC (IATJPOFF, NVECFF, 'IATJPOFF', 'READMIX') + CALL ALLOC (IASPARFF, NVECFF, 'ISPARFF', 'READMIX') + READ (78) (IVECFF(I),I=1,NVECFF) + IATJPOFF(:NVECFF) = IATJP + IASPARFF(:NVECFF) = IASPA + READ (78) EAVFF, (EVALFF(I),I=1,NVECFF) + + READ (78) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) ! ! Close the initial state mixing file ! ! CLOSE(78) - ENDIF - - RETURN - END SUBROUTINE READMIX + ENDIF + + RETURN + END SUBROUTINE READMIX diff --git a/src/appl/rtransition90/readmix_I.f90 b/src/appl/rtransition90/readmix_I.f90 index 96a557972..b4248beef 100644 --- a/src/appl/rtransition90/readmix_I.f90 +++ b/src/appl/rtransition90/readmix_I.f90 @@ -1,12 +1,12 @@ - MODULE readmix_I + MODULE readmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE readmix (NAME, INPCI, INIT) - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - INTEGER :: INPCI - INTEGER, INTENT(IN) :: INIT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE readmix (NAME, INPCI, INIT) + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + INTEGER :: INPCI + INTEGER, INTENT(IN) :: INIT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/setcsl.f90 b/src/appl/rtransition90/setcsl.f90 index 1d4583c83..1f2e8a6ba 100644 --- a/src/appl/rtransition90/setcsl.f90 +++ b/src/appl/rtransition90/setcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSL + SUBROUTINE SETCSL ! * ! Open, check, load data from and close the .csl file. This file * ! is always attached to stream 21. * @@ -10,62 +10,62 @@ SUBROUTINE SETCSL ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcsl_I + USE openfl_I + USE lodcsl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS, NCORE - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: IERR, IOS, NCORE + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! ! The .csl file is FORMATTED; it must exist ! - DEFNAM = 'rcsl.inp' - FORM = 'FORMATTED' - STATUS = 'OLD' + DEFNAM = 'rcsl.inp' + FORM = 'FORMATTED' + STATUS = 'OLD' ! ! Look for grasp92.csl ! - INQUIRE(FILE=DEFNAM, EXIST=FOUND) + INQUIRE(FILE=DEFNAM, EXIST=FOUND) ! - IF (FOUND) THEN - FILNAM = DEFNAM - ELSE - WRITE (6, *) 'rcsl.inp does not exist' - STOP - ENDIF + IF (FOUND) THEN + FILNAM = DEFNAM + ELSE + WRITE (6, *) 'rcsl.inp does not exist' + STOP + ENDIF ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening rcsl.inp' - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening rcsl.inp' + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSL (NCORE) + CALL LODCSL (NCORE) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN - END SUBROUTINE SETCSL + RETURN + END SUBROUTINE SETCSL diff --git a/src/appl/rtransition90/setcsl_I.f90 b/src/appl/rtransition90/setcsl_I.f90 index 7d4331f94..c9303318c 100644 --- a/src/appl/rtransition90/setcsl_I.f90 +++ b/src/appl/rtransition90/setcsl_I.f90 @@ -1,9 +1,9 @@ - MODULE setcsl_I + MODULE setcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsl - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcsl + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/setcslm.f90 b/src/appl/rtransition90/setcslm.f90 index f32c1c590..306329a70 100644 --- a/src/appl/rtransition90/setcslm.f90 +++ b/src/appl/rtransition90/setcslm.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLM + SUBROUTINE SETCSLM ! * ! Open, check, load data from and close the .csl file. This file * ! is always attached to stream 21. * @@ -10,62 +10,62 @@ SUBROUTINE SETCSLM ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslm_I + USE openfl_I + USE lodcslm_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS, NCORE - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: IERR, IOS, NCORE + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! ! The .csl file is FORMATTED; it must exist ! - DEFNAM = 'SLASK' - FORM = 'FORMATTED' - STATUS = 'OLD' + DEFNAM = 'SLASK' + FORM = 'FORMATTED' + STATUS = 'OLD' ! ! Look for grasp92.csl ! - INQUIRE(FILE=DEFNAM, EXIST=FOUND) + INQUIRE(FILE=DEFNAM, EXIST=FOUND) ! - IF (FOUND) THEN - FILNAM = DEFNAM - ELSE - WRITE (6, *) 'rcsl.inp does not exist' - STOP - ENDIF + IF (FOUND) THEN + FILNAM = DEFNAM + ELSE + WRITE (6, *) 'rcsl.inp does not exist' + STOP + ENDIF ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening rcsl.inp' - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening rcsl.inp' + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21, STATUS='DELETE') - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21, STATUS='DELETE') + ENDIF ! ! Load data from the .csl file ! - CALL LODCSLM (NCORE) + CALL LODCSLM (NCORE) ! ! Close the .csl file ! - CLOSE(21, STATUS='DELETE') + CLOSE(21, STATUS='DELETE') ! - RETURN - END SUBROUTINE SETCSLM + RETURN + END SUBROUTINE SETCSLM diff --git a/src/appl/rtransition90/setcslm_I.f90 b/src/appl/rtransition90/setcslm_I.f90 index aa7b321a3..2b998020f 100644 --- a/src/appl/rtransition90/setcslm_I.f90 +++ b/src/appl/rtransition90/setcslm_I.f90 @@ -1,9 +1,9 @@ - MODULE setcslm_I + MODULE setcslm_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcslm - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcslm + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/spme.f90 b/src/appl/rtransition90/spme.f90 index 5cdbdbc70..a05ee136d 100644 --- a/src/appl/rtransition90/spme.f90 +++ b/src/appl/rtransition90/spme.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) + SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) ! * ! This routine calculates the reduced matrix elements for pair I,J * ! in either Coulomb/Babuskin gauge or for magnetic case. * @@ -10,13 +10,13 @@ SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) ! ative transitions paper. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:05:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:05:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bess_C USE biorb_C USE debug_C @@ -29,253 +29,253 @@ SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I - USE quad_I + USE clrx_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: I,J - REAL(DOUBLE), INTENT(OUT) :: HCOUL, HBAB, HMAG + INTEGER, INTENT(IN) :: I,J + REAL(DOUBLE), INTENT(OUT) :: HCOUL, HBAB, HMAG !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NKJI, NKJJ, IPJ, NAKI, NAKJ, II, LP, LM + INTEGER :: NKJI, NKJJ, IPJ, NAKI, NAKJ, II, LP, LM REAL(DOUBLE) :: EPS, HGAUGE, TJI, TJJ, FACT, FORM, FL, FLP, DFKI, DFKJ, & CLP, CLM, CIPLP, CIMLP, CIPLM, CIMLM, VALUE, CJL, CIP, TAROM, ESTHER, & TEKEL, PERES, TAMAR, ENOCH, SETH, SHEM, DARIUS, CYRUS, DANIEL, BOAZ, & - ESAU, AARON, GIMEL + ESAU, AARON, GIMEL !----------------------------------------------- - + ! - EPS = 1.0D-10 + EPS = 1.0D-10 ! IF (LDBPR(12) .OR. LDBPR(13) .OR. LDBPR(14) .OR. LDBPR(15)) WRITE (99, & - 303) I, J + 303) I, J ! - HMAG = 0.0D00 - HCOUL = 0.0D00 - HGAUGE = 0.0D00 - HBAB = 0.0D00 + HMAG = 0.0D00 + HCOUL = 0.0D00 + HGAUGE = 0.0D00 + HBAB = 0.0D00 ! ! Evaluate factor multiplying Mbar(a,b) ! - NKJI = NKJ(I) - NKJJ = NKJ(J) - TJI = DBLE(NKJI) - TJJ = DBLE(NKJJ) - FACT = 1.0D00 - IPJ = (NKJI + 1)/2 + NKJJ - IF (MOD(IPJ,2) /= 0) FACT = -FACT - NAKI = NAK(I) - NAKJ = NAK(J) - FORM = FACT*SQRT(TJJ + 1.0D00)*CLRX(NAKJ,LK,NAKI) - FL = DBLE(LK) - FLP = FL + 1.0D00 - DFKI = DBLE(NAKI) - DFKJ = DBLE(NAKJ) + NKJI = NKJ(I) + NKJJ = NKJ(J) + TJI = DBLE(NKJI) + TJJ = DBLE(NKJJ) + FACT = 1.0D00 + IPJ = (NKJI + 1)/2 + NKJJ + IF (MOD(IPJ,2) /= 0) FACT = -FACT + NAKI = NAK(I) + NAKJ = NAK(J) + FORM = FACT*SQRT(TJJ + 1.0D00)*CLRX(NAKJ,LK,NAKI) + FL = DBLE(LK) + FLP = FL + 1.0D00 + DFKI = DBLE(NAKI) + DFKJ = DBLE(NAKJ) ! - MTP = MIN(MFII(NNII(I)),MFFF(NNFF(J))) + MTP = MIN(MFII(NNII(I)),MFFF(NNFF(J))) ! - IF (KK == 0) THEN + IF (KK == 0) THEN ! - IF (ABS(FORM) > EPS) THEN + IF (ABS(FORM) > EPS) THEN ! ! To pick the right initial and final state radial functions convert ! from orbital order of the merged list to the orbital orders of the ! initial and final state lists, respectively. ! N(I) -> NNII(I), N(J) -> NNFF(J) ! - DO II = 1, N + DO II = 1, N TB(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) + QFII(II,NNII(I))*& - PFFF(II,NNFF(J)) + PFFF(II,NNFF(J)) TC(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) - QFII(II,NNII(I))*& - PFFF(II,NNFF(J)) + PFFF(II,NNFF(J)) ! zou - TB(II) = TB(II)*C/CVAC - TC(II) = TC(II)*C/CVAC + TB(II) = TB(II)*C/CVAC + TC(II) = TC(II)*C/CVAC TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) + QFII(II,NNII(I))*& - QFFF(II,NNFF(J))*(C/CVAC)**2 + QFFF(II,NNFF(J))*(C/CVAC)**2 ! TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) + ! : QFII(II,NNII(I))*QFFF(II,NNFF(J)) ! zou - END DO - LP = LK + 1 - LM = LK - 1 + END DO + LP = LK + 1 + LM = LK - 1 ! ! Calculate Coulomb coefficients ! - CLP = SQRT(FL/FLP) - CLM = -SQRT(FLP/FL) - CIPLP = CLP*(DFKI - DFKJ) - CIMLP = CLP*FLP - CIPLM = CLM*(DFKI - DFKJ) - CIMLM = -CLM*FL + CLP = SQRT(FL/FLP) + CLM = -SQRT(FLP/FL) + CIPLP = CLP*(DFKI - DFKJ) + CIMLP = CLP*FLP + CIPLM = CLM*(DFKI - DFKJ) + CIMLM = -CLM*FL ! ! Tabulate Coulomb integrand ! - TA(1) = 0.0D00 + TA(1) = 0.0D00 TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,3)*(CIPLP*TB(2:MTP)+CIMLP*TC(2:MTP)& - )+BJ(2:MTP,1)*(CIPLM*TB(2:MTP)+CIMLM*TC(2:MTP))) - CALL QUAD (VALUE) - HCOUL = FORM*VALUE + )+BJ(2:MTP,1)*(CIPLM*TB(2:MTP)+CIMLM*TC(2:MTP))) + CALL QUAD (VALUE) + HCOUL = FORM*VALUE ! ! Calculate gauge dependent coefficients ! - CJL = -(FL + FLP) - CIP = DFKI - DFKJ + CJL = -(FL + FLP) + CIP = DFKI - DFKJ ! ! Tabulate gauge dependent integrand ! - TA(1) = 0.0D00 + TA(1) = 0.0D00 TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,2)*(CJL*TD(2:MTP))+BJ(2:MTP,3)*(CIP& *TB(2:MTP)+FLP*TC(2:MTP))+BJ(2:MTP,1)*(CIP*TB(2:MTP)-FL*TC(2:MTP& - ))) + ))) ! ! Print gauge dependent integrand if requested ! - IF (LDBPR(13)) WRITE (99, 300) I, J, (II,TA(II),II=1,N) - CALL QUAD (VALUE) - HGAUGE = FORM*VALUE - HBAB = HCOUL + SQRT(FLP/FL)*HGAUGE + IF (LDBPR(13)) WRITE (99, 300) I, J, (II,TA(II),II=1,N) + CALL QUAD (VALUE) + HGAUGE = FORM*VALUE + HBAB = HCOUL + SQRT(FLP/FL)*HGAUGE ! ! Print Coulomb and gauge dependent integrals if requested ! - IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB + IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB ! ! Calculate the contibutions from various terms if requested ! - IF (LDBPR(14) .OR. LDBPR(15)) THEN -! - TA(1) = 0.0D00 - TA(2:MTP) = TD(2:MTP)*BJ(2:MTP,2)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (TAROM) - IF (LDBPR(14)) WRITE (99, 305) TAROM - ESTHER = -CJL - IF (LDBPR(14)) WRITE (99, 306) ESTHER - TEKEL = ESTHER*TAROM - IF (LDBPR(14)) WRITE (99, 307) TEKEL -! - TA(1) = 0.0D00 - TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,3)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (PERES) - IF (LDBPR(14)) THEN - WRITE (99, 308) PERES - WRITE (99, 306) CIP - ENDIF - TAMAR = CIP*PERES - IF (LDBPR(14)) WRITE (99, 307) TAMAR -! - TA(1) = 0.0D00 - TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,1)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (ENOCH) - IF (LDBPR(14)) THEN - WRITE (99, 309) ENOCH - WRITE (99, 306) CIP - ENDIF - SETH = CIP*ENOCH - IF (LDBPR(14)) WRITE (99, 307) SETH -! - TA(1) = 0.0D00 - TA(2:MTP) = BJ(2:MTP,1)*TC(2:MTP)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (SHEM) - IF (LDBPR(14)) THEN - WRITE (99, 310) SHEM - WRITE (99, 306) FL - ENDIF - DARIUS = FL*SHEM - IF (LDBPR(14)) WRITE (99, 307) DARIUS -! - TA(1) = 0.0D00 - TA(2:MTP) = -BJ(2:MTP,3)*TC(2:MTP)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (CYRUS) - IF (LDBPR(14)) WRITE (99, 311) CYRUS - DANIEL = FLP - IF (LDBPR(14)) WRITE (99, 306) DANIEL - BOAZ = DANIEL*CYRUS - IF (LDBPR(14)) WRITE (99, 307) BOAZ -! - ESAU = TAMAR + SETH + DARIUS + BOAZ - IF (LDBPR(14)) WRITE (99, 312) ESAU, TEKEL - AARON = ESAU + TEKEL - GIMEL = -VALUE - IF (LDBPR(14)) THEN - WRITE (99, 313) AARON, GIMEL - WRITE (99, 314) - WRITE (99, 315) PERES, CIP, TAMAR - WRITE (99, 316) ENOCH, CIP, SETH - WRITE (99, 317) SHEM, FL, DARIUS - WRITE (99, 318) CYRUS, DANIEL, BOAZ - WRITE (99, 319) ESAU - WRITE (99, 320) TAROM, ESTHER, TEKEL - WRITE (99, 321) GIMEL, AARON - ENDIF -! - ENDIF -! - ENDIF -! - IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB -! - ELSE + IF (LDBPR(14) .OR. LDBPR(15)) THEN +! + TA(1) = 0.0D00 + TA(2:MTP) = TD(2:MTP)*BJ(2:MTP,2)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (TAROM) + IF (LDBPR(14)) WRITE (99, 305) TAROM + ESTHER = -CJL + IF (LDBPR(14)) WRITE (99, 306) ESTHER + TEKEL = ESTHER*TAROM + IF (LDBPR(14)) WRITE (99, 307) TEKEL +! + TA(1) = 0.0D00 + TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,3)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (PERES) + IF (LDBPR(14)) THEN + WRITE (99, 308) PERES + WRITE (99, 306) CIP + ENDIF + TAMAR = CIP*PERES + IF (LDBPR(14)) WRITE (99, 307) TAMAR +! + TA(1) = 0.0D00 + TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,1)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (ENOCH) + IF (LDBPR(14)) THEN + WRITE (99, 309) ENOCH + WRITE (99, 306) CIP + ENDIF + SETH = CIP*ENOCH + IF (LDBPR(14)) WRITE (99, 307) SETH +! + TA(1) = 0.0D00 + TA(2:MTP) = BJ(2:MTP,1)*TC(2:MTP)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (SHEM) + IF (LDBPR(14)) THEN + WRITE (99, 310) SHEM + WRITE (99, 306) FL + ENDIF + DARIUS = FL*SHEM + IF (LDBPR(14)) WRITE (99, 307) DARIUS +! + TA(1) = 0.0D00 + TA(2:MTP) = -BJ(2:MTP,3)*TC(2:MTP)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (CYRUS) + IF (LDBPR(14)) WRITE (99, 311) CYRUS + DANIEL = FLP + IF (LDBPR(14)) WRITE (99, 306) DANIEL + BOAZ = DANIEL*CYRUS + IF (LDBPR(14)) WRITE (99, 307) BOAZ +! + ESAU = TAMAR + SETH + DARIUS + BOAZ + IF (LDBPR(14)) WRITE (99, 312) ESAU, TEKEL + AARON = ESAU + TEKEL + GIMEL = -VALUE + IF (LDBPR(14)) THEN + WRITE (99, 313) AARON, GIMEL + WRITE (99, 314) + WRITE (99, 315) PERES, CIP, TAMAR + WRITE (99, 316) ENOCH, CIP, SETH + WRITE (99, 317) SHEM, FL, DARIUS + WRITE (99, 318) CYRUS, DANIEL, BOAZ + WRITE (99, 319) ESAU + WRITE (99, 320) TAROM, ESTHER, TEKEL + WRITE (99, 321) GIMEL, AARON + ENDIF +! + ENDIF +! + ENDIF +! + IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB +! + ELSE ! ! Tabulate magnetic integrand ! - IF (ABS(FORM) > EPS) THEN + IF (ABS(FORM) > EPS) THEN ! - TA(1) = 0.0D00 - DO II = 2, MTP + TA(1) = 0.0D00 + DO II = 2, MTP !zou TA(II) = (PFII(II,NNII(I))*QFFF(II,NNFF(J))+QFII(II,NNII(I))*& - PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)*C/CVAC + PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)*C/CVAC ! TA(II) = (PFII(II,NNII(I))*QFFF(II,NNFF(J)) + ! : QFII(II,NNII(I))*PFFF(II,NNFF(J)))*BJ(II,2)*RP(II) !zou - END DO - CALL QUAD (VALUE) - IF (LDBPR(14)) WRITE (99, 322) VALUE - HMAG = -VALUE*(FL + FLP)*(DFKI + DFKJ)*FORM/SQRT(FL*FLP) + END DO + CALL QUAD (VALUE) + IF (LDBPR(14)) WRITE (99, 322) VALUE + HMAG = -VALUE*(FL + FLP)*(DFKI + DFKJ)*FORM/SQRT(FL*FLP) ! - ENDIF + ENDIF ! - IF (LDBPR(12)) WRITE (99, 302) HMAG + IF (LDBPR(12)) WRITE (99, 302) HMAG ! - ENDIF + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,1X,20X,'Local form of gauge dependent integral for',' orbitals',& - I3,' and',I3,/,/,100(1X,7(I3,2X,1P,D11.3,2X),/)) + I3,' and',I3,/,/,100(1X,7(I3,2X,1P,D11.3,2X),/)) 301 FORMAT(/,1X,'Orbital pair (',I2,',',I2,') integrals:','Coul. gauge ',1P,D& - 13.3,3X,'Gauge contribution',D13.3,3X,'Bab.gauge',D13.3) - 302 FORMAT(/,1X,'Magnetic single particle matrix element ',1P,D13.3) + 13.3,3X,'Gauge contribution',D13.3,3X,'Bab.gauge',D13.3) + 302 FORMAT(/,1X,'Magnetic single particle matrix element ',1P,D13.3) 303 FORMAT(/,1X,30('+'),' SPME called for orbitals ',I4,' and',I4,3X,30(& - '+')) - 304 FORMAT(/,100(1X,7(I3,2X,1P,D11.3,2X),/),/) - 305 FORMAT(/,' Integral J(L) = ',1P,D28.12) - 306 FORMAT(' Factor multiplying this ',1P,D20.12) - 307 FORMAT(' Resultant contribution ',1P,D20.12,/) - 308 FORMAT(' I + (L+1) integral = ',1P,D24.12) - 309 FORMAT(' I + (L-1) integral = ',1P,D24.12) - 310 FORMAT(' I - (L-1) integral = ',1P,D24.12) - 311 FORMAT(' I - (L+1) integral = ',1P,D24.12) + '+')) + 304 FORMAT(/,100(1X,7(I3,2X,1P,D11.3,2X),/),/) + 305 FORMAT(/,' Integral J(L) = ',1P,D28.12) + 306 FORMAT(' Factor multiplying this ',1P,D20.12) + 307 FORMAT(' Resultant contribution ',1P,D20.12,/) + 308 FORMAT(' I + (L+1) integral = ',1P,D24.12) + 309 FORMAT(' I + (L-1) integral = ',1P,D24.12) + 310 FORMAT(' I - (L-1) integral = ',1P,D24.12) + 311 FORMAT(' I - (L+1) integral = ',1P,D24.12) 312 FORMAT(' These last four add up to ',1P,D20.12,& - ' compared to the first which is ',D20.12) - 313 FORMAT(' These all add up to ',1P,D20.12,' which should equal ',D20.12) - 314 FORMAT(/,18X,'Integral',11X,'Coefficient',8X,'Contribution') - 315 FORMAT(' I + (L+1)',1P,3D20.10) - 316 FORMAT(' I + (L-1)',1P,3D20.10) - 317 FORMAT(' I - (L-1)',1P,3D20.10) - 318 FORMAT(' I - (L+1)',1P,3D20.10) - 319 FORMAT(54X,16('-'),/,50X,1P,D20.10) - 320 FORMAT(' J (L)',4X,1P,3D20.10) - 321 FORMAT(54X,16('-'),/,' Correct figure',1P,D20.10,15X,D20.10) - 322 FORMAT(' I + (L) integral',1P,D20.10) - RETURN -! - END SUBROUTINE SPME + ' compared to the first which is ',D20.12) + 313 FORMAT(' These all add up to ',1P,D20.12,' which should equal ',D20.12) + 314 FORMAT(/,18X,'Integral',11X,'Coefficient',8X,'Contribution') + 315 FORMAT(' I + (L+1)',1P,3D20.10) + 316 FORMAT(' I + (L-1)',1P,3D20.10) + 317 FORMAT(' I - (L-1)',1P,3D20.10) + 318 FORMAT(' I - (L+1)',1P,3D20.10) + 319 FORMAT(54X,16('-'),/,50X,1P,D20.10) + 320 FORMAT(' J (L)',4X,1P,3D20.10) + 321 FORMAT(54X,16('-'),/,' Correct figure',1P,D20.10,15X,D20.10) + 322 FORMAT(' I + (L) integral',1P,D20.10) + RETURN +! + END SUBROUTINE SPME diff --git a/src/appl/rtransition90/spme_I.f90 b/src/appl/rtransition90/spme_I.f90 index 6ad588cac..0692e2b25 100644 --- a/src/appl/rtransition90/spme_I.f90 +++ b/src/appl/rtransition90/spme_I.f90 @@ -1,15 +1,15 @@ - MODULE spme_I + MODULE spme_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spme (I, J, HCOUL, HBAB, HMAG) - USE vast_kind_param, ONLY: DOUBLE - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: HCOUL - REAL(DOUBLE), INTENT(OUT) :: HBAB - REAL(DOUBLE), INTENT(OUT) :: HMAG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE spme (I, J, HCOUL, HBAB, HMAG) + USE vast_kind_param, ONLY: DOUBLE + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: HCOUL + REAL(DOUBLE), INTENT(OUT) :: HBAB + REAL(DOUBLE), INTENT(OUT) :: HMAG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/strsum.f90 b/src/appl/rtransition90/strsum.f90 index 09b1dbdaa..b99bed4da 100644 --- a/src/appl/rtransition90/strsum.f90 +++ b/src/appl/rtransition90/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM(NAME, INPCI, ILBL) + SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! * ! Generates the first part of oscl92.sum (on stream 24). * ! * @@ -9,13 +9,13 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE decide_C USE def_C @@ -32,27 +32,27 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INPCI - INTEGER :: ILBL - CHARACTER, INTENT(IN) :: NAME(2)*24 + INTEGER, INTENT(IN) :: INPCI + INTEGER :: ILBL + CHARACTER, INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J - CHARACTER :: RECORD*15, CTIME*8, CDATE*8 + INTEGER :: I, J + CHARACTER :: RECORD*15, CTIME*8, CDATE*8 !----------------------------------------------- - - - I = INDEX(NAME(1),' ') - J = INDEX(NAME(2),' ') + + + I = INDEX(NAME(1),' ') + J = INDEX(NAME(2),' ') IF(ILBL == 0) THEN - IF (INPCI == 0) THEN + IF (INPCI == 0) THEN OPEN(UNIT=24,FILE=NAME(1)(1:I-1)//'.'//NAME(2)(1:J-1)//'.ct',FORM=& - 'FORMATTED', STATUS='UNKNOWN',POSITION='asis') - ELSE + 'FORMATTED', STATUS='UNKNOWN',POSITION='asis') + ELSE OPEN(UNIT=24,FILE=NAME(1)(1:I-1)//'.'//NAME(2)(1:J-1)//'.t',FORM=& - 'FORMATTED',STATUS='UNKNOWN',POSITION='asis') - ENDIF + 'FORMATTED',STATUS='UNKNOWN',POSITION='asis') + ENDIF ELSE IF(ILBL == 1) THEN IF(IOPEN_STATUS1.EQ.0 .AND. IOPEN_STATUS2 .EQ.0) THEN IF (INPCI == 0) THEN @@ -167,7 +167,7 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! WRITE (24,*) ! CALL ENGOUT1 (EAVFF,EVALFF,IATJPOFF,IASPARFF,IVECFF,NVECFF,3,2) ! - RETURN + RETURN ! 300 FORMAT ('The atomic number is ',1F14.10,';') 301 FORMAT (' c =',1P,1D19.12,' Bohr radii,' & @@ -191,6 +191,6 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) 'gamma',19X,'P(2)',18X,'Q(2)',10X,'MTP') 310 FORMAT (3X,1I2,1A2,1X,1P,5(3X,1D19.12),3X,1I3) - RETURN + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rtransition90/strsum_I.f90 b/src/appl/rtransition90/strsum_I.f90 index 18f6b4bae..5cdcbe387 100644 --- a/src/appl/rtransition90/strsum_I.f90 +++ b/src/appl/rtransition90/strsum_I.f90 @@ -1,12 +1,12 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum (NAME, INPCI,ILBL) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: INPCI + SUBROUTINE strsum (NAME, INPCI,ILBL) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: INPCI INTEGER :: ILBL - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/testmix.f90 b/src/appl/rtransition90/testmix.f90 index 85f5a22b8..d92b89433 100644 --- a/src/appl/rtransition90/testmix.f90 +++ b/src/appl/rtransition90/testmix.f90 @@ -1,17 +1,17 @@ !*********************************************************************** ! * - SUBROUTINE TESTMIX + SUBROUTINE TESTMIX ! * ! This routine checks the mixing coefficients * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE def_C USE eigv_C @@ -21,34 +21,34 @@ SUBROUTINE TESTMIX !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! ! - - WRITE (*, *) ' ****************' - WRITE (*, *) ' Entering testmix' - WRITE (*, *) ' ****************' - WRITE (*, *) - WRITE (*, *) 'Initial state' - WRITE (*, *) 'EVALII', (EAVII + EVALII(I),I=1,NVECII) + + WRITE (*, *) ' ****************' + WRITE (*, *) ' Entering testmix' + WRITE (*, *) ' ****************' + WRITE (*, *) + WRITE (*, *) 'Initial state' + WRITE (*, *) 'EVALII', (EAVII + EVALII(I),I=1,NVECII) WRITE (*, *) 'NELECII,NCFII,NWII,NVECMXII', NELECII, NCFII, NWII, NVECMXII - WRITE (*, *) NVECII - WRITE (*, *) (IVECII(I),I=1,NVECII) - WRITE (*, *) (IATJPOII(I),IASPARII(I),I=1,NVECII) - WRITE (*, *) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) - - WRITE (*, *) 'Final state' - WRITE (*, *) 'EVALFF', (EAVFF + EVALFF(I),I=1,NVECFF) + WRITE (*, *) NVECII + WRITE (*, *) (IVECII(I),I=1,NVECII) + WRITE (*, *) (IATJPOII(I),IASPARII(I),I=1,NVECII) + WRITE (*, *) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) + + WRITE (*, *) 'Final state' + WRITE (*, *) 'EVALFF', (EAVFF + EVALFF(I),I=1,NVECFF) WRITE (*, *) 'NELECFF,NCFFF,NWFF,NVECMXFF', NELECFF, NCFFF, NWFF, NVECMXFF - WRITE (*, *) NVECFF - WRITE (*, *) (IVECFF(I),I=1,NVECFF) - WRITE (*, *) (IATJPOFF(I),IASPARFF(I),I=1,NVECFF) - WRITE (*, *) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) - WRITE (*, *) - WRITE (*, *) ' ***************' - WRITE (*, *) ' Leaving testmix' - WRITE (*, *) ' ***************' - - RETURN - END SUBROUTINE TESTMIX + WRITE (*, *) NVECFF + WRITE (*, *) (IVECFF(I),I=1,NVECFF) + WRITE (*, *) (IATJPOFF(I),IASPARFF(I),I=1,NVECFF) + WRITE (*, *) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) + WRITE (*, *) + WRITE (*, *) ' ***************' + WRITE (*, *) ' Leaving testmix' + WRITE (*, *) ' ***************' + + RETURN + END SUBROUTINE TESTMIX diff --git a/src/appl/rtransition90/testmix_I.f90 b/src/appl/rtransition90/testmix_I.f90 index 940c89b0c..ab709c532 100644 --- a/src/appl/rtransition90/testmix_I.f90 +++ b/src/appl/rtransition90/testmix_I.f90 @@ -1,9 +1,9 @@ - MODULE testmix_I + MODULE testmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE testmix - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE testmix + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90/trsort.f90 b/src/appl/rtransition90/trsort.f90 index f34a94801..268df70ca 100644 --- a/src/appl/rtransition90/trsort.f90 +++ b/src/appl/rtransition90/trsort.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) + SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! * ! Routine to sort angular coefficients into list based on integral * ! labels rather than CSF. A tree sort is used. To save space, the * @@ -15,13 +15,13 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! Last update: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE default_C @@ -30,24 +30,24 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alclla_I - USE alcnma_I + USE alclla_I + USE alcnma_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NFILE2 - INTEGER :: JKP - INTEGER, INTENT(IN) :: IBLKI - INTEGER, INTENT(IN) :: IBLKF - LOGICAL, INTENT(IN) :: LPRINT - CHARACTER, INTENT(IN) :: NAME(2)*24 + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NFILE2 + INTEGER :: JKP + INTEGER, INTENT(IN) :: IBLKI + INTEGER, INTENT(IN) :: IBLKF + LOGICAL, INTENT(IN) :: LPRINT + CHARACTER, INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NCA = 65536 - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: NCA = 65536 + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -55,10 +55,10 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ILAST, IBLINT, IPTCSF, LBLINT, JLABL, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR, XL INTEGER :: NMCP, NINT, NLABEL, LLDIM, NMDIM, IR, IS, NI, I, M, J, & - ICOUNT, JLAB, K, L, IMCP, J1, J2, MLR, MUP, INTS, IA, IB + ICOUNT, JLAB, K, L, IMCP, J1, J2, MLR, MUP, INTS, IA, IB REAL(DOUBLE) :: X - LOGICAL :: FIRST - CHARACTER(LEN=2), DIMENSION(-9:9) :: S + LOGICAL :: FIRST + CHARACTER(LEN=2), DIMENSION(-9:9) :: S !----------------------------------------------- ! ! @@ -68,300 +68,300 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! POINTER (PIPTR,IPTR(1)) ! ! - S((-9)) = '-9' - S((-8)) = '-8' - S((-7)) = '-7' - S((-6)) = '-6' - S((-5)) = '-5' - S((-4)) = '-4' - S((-3)) = '-3' - S((-2)) = '-2' - S((-1)) = '-1' - S(0) = '+0' - S(1) = '+1' - S(2) = '+2' - S(3) = '+3' - S(4) = '+4' - S(5) = '+5' - S(6) = '+6' - S(7) = '+7' - S(8) = '+8' - S(9) = '+9' + S((-9)) = '-9' + S((-8)) = '-8' + S((-7)) = '-7' + S((-6)) = '-6' + S((-5)) = '-5' + S((-4)) = '-4' + S((-3)) = '-3' + S((-2)) = '-2' + S((-1)) = '-1' + S(0) = '+0' + S(1) = '+1' + S(2) = '+2' + S(3) = '+3' + S(4) = '+4' + S(5) = '+5' + S(6) = '+6' + S(7) = '+7' + S(8) = '+8' + S(9) = '+9' ! ! Position file at beginning of list of integrals ! - REWIND (NFILE) + REWIND (NFILE) ! ! Initialize ! - FIRST = .TRUE. - NMCP = 0 - NINT = 0 + FIRST = .TRUE. + NMCP = 0 + NINT = 0 ! ! Initial allocation of storage to local arrays ! - NLABEL = 1 - CALL ALLOC (JLABL, NLABEL, 'JLABL', 'TRSORT') - CALL ALLOC (XL, NLABEL, 'XL', 'TRSORT') + NLABEL = 1 + CALL ALLOC (JLABL, NLABEL, 'JLABL', 'TRSORT') + CALL ALLOC (XL, NLABEL, 'XL', 'TRSORT') ! CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, 1) - CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 1) + LLDIM, 1) + CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 1) ! ! Now the rest of the elements ! - 1 CONTINUE - READ (NFILE, END=12) IR, IS, NI - IF (NI > NLABEL) THEN - CALL RALLOC (JLABL, NI, 'JLABL', 'TRSORT') - CALL RALLOC (XL, NI, 'XL', 'TRSORT') - NLABEL = NI - ENDIF - READ (NFILE, END=99, ERR=99) (JLABL(I),XL(I),I=1,NI) - IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 1 + 1 CONTINUE + READ (NFILE, END=12) IR, IS, NI + IF (NI > NLABEL) THEN + CALL RALLOC (JLABL, NI, 'JLABL', 'TRSORT') + CALL RALLOC (XL, NI, 'XL', 'TRSORT') + NLABEL = NI + ENDIF + READ (NFILE, END=99, ERR=99) (JLABL(I),XL(I),I=1,NI) + IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 1 ! - IF (FIRST) THEN + IF (FIRST) THEN ! ! List is empty ! - M = 0 - J = 0 + M = 0 + J = 0 ! ! Set up list pointers and insert first element ! - ICOUNT = 0 - 3 CONTINUE - ICOUNT = ICOUNT + 1 - IF (ICOUNT > NI) GO TO 1 - IF (JLABL(ICOUNT) == 0) GO TO 3 - ILAB(1) = JLABL(ICOUNT) + ICOUNT = 0 + 3 CONTINUE + ICOUNT = ICOUNT + 1 + IF (ICOUNT > NI) GO TO 1 + IF (JLABL(ICOUNT) == 0) GO TO 3 + ILAB(1) = JLABL(ICOUNT) ! - IRIGHT(1) = 0 - ILEFT(1) = 0 - IBEG(1) = 1 - IPTR(1) = 0 - ILAST(1) = 0 + IRIGHT(1) = 0 + ILEFT(1) = 0 + IBEG(1) = 1 + IPTR(1) = 0 + ILAST(1) = 0 ! - M = 1 - J = 1 + M = 1 + J = 1 ! - FIRST = .FALSE. + FIRST = .FALSE. ! - ELSE + ELSE ! - ICOUNT = 0 + ICOUNT = 0 ! - ENDIF + ENDIF ! ! Sort integral list using tree sort ! ! Take next nonzero element ! - 4 CONTINUE - ICOUNT = ICOUNT + 1 - IF (ICOUNT > NI) GO TO 1 - JLAB = JLABL(ICOUNT) - IF (JLAB == 0) GO TO 4 - X = XL(ICOUNT) + 4 CONTINUE + ICOUNT = ICOUNT + 1 + IF (ICOUNT > NI) GO TO 1 + JLAB = JLABL(ICOUNT) + IF (JLAB == 0) GO TO 4 + X = XL(ICOUNT) ! - M = M + 1 - IF (M > NMDIM) CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 2) - I = 1 + M = M + 1 + IF (M > NMDIM) CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 2) + I = 1 ! ! Search for place in tree ! - 5 CONTINUE - IF (JLAB - ILAB(I) > 0) GO TO 8 - IF (JLAB - ILAB(I) == 0) GO TO 10 - K = IRIGHT(I) - IF (K /= 0) GO TO 7 - J = J + 1 + 5 CONTINUE + IF (JLAB - ILAB(I) > 0) GO TO 8 + IF (JLAB - ILAB(I) == 0) GO TO 10 + K = IRIGHT(I) + IF (K /= 0) GO TO 7 + J = J + 1 IF (J > LLDIM) CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, & - IRIGHT, LBLINT, LLDIM, 2) - IRIGHT(I) = J - GO TO 9 - 7 CONTINUE - I = K - GO TO 5 - 8 CONTINUE - K = ILEFT(I) - IF (K /= 0) GO TO 7 - J = J + 1 + IRIGHT, LBLINT, LLDIM, 2) + IRIGHT(I) = J + GO TO 9 + 7 CONTINUE + I = K + GO TO 5 + 8 CONTINUE + K = ILEFT(I) + IF (K /= 0) GO TO 7 + J = J + 1 IF (J > LLDIM) CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, & - IRIGHT, LBLINT, LLDIM, 2) - ILEFT(I) = J + IRIGHT, LBLINT, LLDIM, 2) + ILEFT(I) = J ! ! When found, update list. ! - 9 CONTINUE - ILAST(J) = I - IRIGHT(J) = 0 - ILEFT(J) = 0 - IBEG(J) = M - ILAB(J) = JLAB - IPTR(M) = 0 - GO TO 4 - 10 CONTINUE - K = IBEG(I) - L = K - K = IPTR(L) - DO WHILE(K /= 0) - L = K - K = IPTR(L) - END DO - IPTR(L) = M - IPTR(M) = 0 - GO TO 4 + 9 CONTINUE + ILAST(J) = I + IRIGHT(J) = 0 + ILEFT(J) = 0 + IBEG(J) = M + ILAB(J) = JLAB + IPTR(M) = 0 + GO TO 4 + 10 CONTINUE + K = IBEG(I) + L = K + K = IPTR(L) + DO WHILE(K /= 0) + L = K + K = IPTR(L) + END DO + IPTR(L) = M + IPTR(M) = 0 + GO TO 4 ! ! The end of the CSF-based file has been reached ! - 12 CONTINUE - IF (.NOT.(FIRST .OR. M==0)) THEN + 12 CONTINUE + IF (.NOT.(FIRST .OR. M==0)) THEN ! ! Sort is complete. Unpack list ! - NMCP = M - NINT = J - L = 0 - M = 0 - I = 1 + NMCP = M + NINT = J + L = 0 + M = 0 + I = 1 ! ! Search for smallest element ! - 13 CONTINUE - K = IRIGHT(I) - DO WHILE(K /= 0) - I = K - K = IRIGHT(I) - END DO + 13 CONTINUE + K = IRIGHT(I) + DO WHILE(K /= 0) + I = K + K = IRIGHT(I) + END DO ! ! Insert in sorted list ! - 14 CONTINUE - IF (ILAB(I) == 0) GO TO 16 - L = L + 1 - LBLINT(L) = ILAB(I) - K = IBEG(I) + 14 CONTINUE + IF (ILAB(I) == 0) GO TO 16 + L = L + 1 + LBLINT(L) = ILAB(I) + K = IBEG(I) ! ! Copy list of pointers to CSF/coefficients into new list ! - M = M + 1 - ISLDR(M) = K - K = IPTR(K) - DO WHILE(K /= 0) - M = M + 1 - ISLDR(M) = K - K = IPTR(K) - END DO - IPTCSF(L) = M - ILAB(I) = 0 + M = M + 1 + ISLDR(M) = K + K = IPTR(K) + DO WHILE(K /= 0) + M = M + 1 + ISLDR(M) = K + K = IPTR(K) + END DO + IPTCSF(L) = M + ILAB(I) = 0 ! ! Next smallest element is on left of last element ! - K = ILEFT(I) - IF (K == 0) GO TO 16 - I = K - GO TO 13 + K = ILEFT(I) + IF (K == 0) GO TO 16 + I = K + GO TO 13 ! ! If no element on left, next smallest is previous element ! - 16 CONTINUE - I = ILAST(I) - IF (I /= 0) GO TO 14 + 16 CONTINUE + I = ILAST(I) + IF (I /= 0) GO TO 14 ! ! List is unpacked. Invert CSF/coefficient pointer list to give ! position list for CSF/coefficients as they are read in ! - DO I = 1, NMCP - K = ISLDR(I) - IPTR(K) = I - END DO + DO I = 1, NMCP + K = ISLDR(I) + IPTR(K) = I + END DO ! ! Now read CSF pairs and coefficients into correct positions in ! sorted list ! - IMCP = 0 - REWIND (NFILE) - 18 CONTINUE - READ (NFILE, END=20) IR, IS, NI - IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 18 - READ (NFILE) (JLABL(I),XL(I),I=1,NI) - DO I = 1, NI - IF (JLABL(I) == 0) CYCLE - IMCP = IMCP + 1 - K = IPTR(IMCP) - ISLDR(K) = IR - ISLDR1(K) = IS + IMCP = 0 + REWIND (NFILE) + 18 CONTINUE + READ (NFILE, END=20) IR, IS, NI + IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 18 + READ (NFILE) (JLABL(I),XL(I),I=1,NI) + DO I = 1, NI + IF (JLABL(I) == 0) CYCLE + IMCP = IMCP + 1 + K = IPTR(IMCP) + ISLDR(K) = IR + ISLDR1(K) = IS ! ISLDR(K) = IR*NCA+IS - XSLDR(K) = XL(I) - END DO - GO TO 18 + XSLDR(K) = XL(I) + END DO + GO TO 18 ! ! The integral-based list is completely known ! - ENDIF - 20 CONTINUE - REWIND (NFILE) + ENDIF + 20 CONTINUE + REWIND (NFILE) ! ! If first set of data open the file and print ! some data to later be able to identify the file ! - IF (IBLKI==1 .AND. IBLKF==1) THEN - J1 = INDEX(NAME(1),' ') - J2 = INDEX(NAME(2),' ') + IF (IBLKI==1 .AND. IBLKF==1) THEN + J1 = INDEX(NAME(1),' ') + J2 = INDEX(NAME(2),' ') OPEN(UNIT=NFILE2,FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(& KP(JKP))//'T', STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - ENDIF - WRITE (NFILE2) IBLKI, IBLKF, NW, NKP - WRITE (NFILE2) NINT - IF (NMCP /= 0) THEN - IF (LPRINT) WRITE (99, 301) - MLR = 1 - DO I = 1, NINT - MUP = IPTCSF(I) - INTS = MUP - MLR + 1 - WRITE (NFILE2) LBLINT(I), INTS - IF (LPRINT) THEN - IA = LBLINT(I)/KEY - IB = MOD(LBLINT(I),KEY) - WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB) - ENDIF - WRITE (NFILE2) (ISLDR(M),ISLDR1(M),XSLDR(M),M=MLR,MUP) - IF (LPRINT) THEN - DO M = MLR, MUP + 'asis') + ENDIF + WRITE (NFILE2) IBLKI, IBLKF, NW, NKP + WRITE (NFILE2) NINT + IF (NMCP /= 0) THEN + IF (LPRINT) WRITE (99, 301) + MLR = 1 + DO I = 1, NINT + MUP = IPTCSF(I) + INTS = MUP - MLR + 1 + WRITE (NFILE2) LBLINT(I), INTS + IF (LPRINT) THEN + IA = LBLINT(I)/KEY + IB = MOD(LBLINT(I),KEY) + WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB) + ENDIF + WRITE (NFILE2) (ISLDR(M),ISLDR1(M),XSLDR(M),M=MLR,MUP) + IF (LPRINT) THEN + DO M = MLR, MUP ! IS = MOD (ISLDR(M),NCA) - IS = ISLDR1(M) + IS = ISLDR1(M) ! IR = ISLDR(M)/NCA - IR = ISLDR(M) - WRITE (99, 303) IR, IS, XSLDR(M) - END DO - ENDIF - MLR = MUP + 1 - END DO + IR = ISLDR(M) + WRITE (99, 303) IR, IS, XSLDR(M) + END DO + ENDIF + MLR = MUP + 1 + END DO ! - ENDIF + ENDIF ! ! Deallocate storage for local arrays ! - CALL DALLOC (JLABL, 'JLABJ', 'TRSORT') - CALL DALLOC (XL, 'XL', 'TRSORT') + CALL DALLOC (JLABL, 'JLABJ', 'TRSORT') + CALL DALLOC (XL, 'XL', 'TRSORT') CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, 3) - CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 3) + LLDIM, 3) + CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 3) ! - RETURN + RETURN ! ! Error handling ! - 99 CONTINUE - WRITE (6, *) 'TRSORT: Error reading CSF-based file.' - STOP + 99 CONTINUE + WRITE (6, *) 'TRSORT: Error reading CSF-based file.' + STOP ! 301 FORMAT(/,/,' k'/,' d (rs) Coefficients:'/,' ab'/,/,/,& - ' a b r s Coefficient'/) - 302 FORMAT(2(2X,I2,A2)) - 303 FORMAT(14X,1I6,2X,1I6,2X,1P,1D22.15) - RETURN + ' a b r s Coefficient'/) + 302 FORMAT(2(2X,I2,A2)) + 303 FORMAT(14X,1I6,2X,1I6,2X,1P,1D22.15) + RETURN ! - END SUBROUTINE TRSORT + END SUBROUTINE TRSORT diff --git a/src/appl/rtransition90/trsort_I.f90 b/src/appl/rtransition90/trsort_I.f90 index 2e38bbbfd..25f4bf7a9 100644 --- a/src/appl/rtransition90/trsort_I.f90 +++ b/src/appl/rtransition90/trsort_I.f90 @@ -1,16 +1,16 @@ - MODULE trsort_I + MODULE trsort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE trsort (NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NFILE2 - LOGICAL, INTENT(IN) :: LPRINT - INTEGER :: JKP - INTEGER, INTENT(IN) :: IBLKI - INTEGER, INTENT(IN) :: IBLKF - END SUBROUTINE - END INTERFACE - END MODULE + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NFILE2 + LOGICAL, INTENT(IN) :: LPRINT + INTEGER :: JKP + INTEGER, INTENT(IN) :: IBLKI + INTEGER, INTENT(IN) :: IBLKF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/Makefile b/src/appl/rtransition90_mpi/Makefile old mode 100755 new mode 100644 index bfcdee50e..333eeb96b --- a/src/appl/rtransition90_mpi/Makefile +++ b/src/appl/rtransition90_mpi/Makefile @@ -34,7 +34,7 @@ APP_OBJ= \ $(EXE): $(APP_OBJ) $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -I $(MODLMPIU90) -o $@ @@ -44,4 +44,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rtransition90_mpi/alclla.f90 b/src/appl/rtransition90_mpi/alclla.f90 index 5a14d971b..738079052 100644 --- a/src/appl/rtransition90_mpi/alclla.f90 +++ b/src/appl/rtransition90_mpi/alclla.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, IMODE) + LLDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -12,8 +12,8 @@ SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -23,68 +23,68 @@ SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: LLDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: LLDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IBEG, ILAB, ILAST, ILEFT, & IPTCSF, IRIGHT, LBLINT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - LLDIM = 64 + LLDIM = 64 ! ! Allocate storage for arrays ! - CALL ALLOC (IBEG, LLDIM, 'IBEG', 'ALCLLA') - CALL ALLOC (ILAB, LLDIM, 'ILAB', 'ALCLLA') - CALL ALLOC (ILAST, LLDIM, 'ILAST', 'ALCLLA') - CALL ALLOC (ILEFT, LLDIM, 'ILEFT', 'ALCLLA') - CALL ALLOC (IPTCSF, LLDIM, 'IPTCSF', 'ALCLLA') - CALL ALLOC (IRIGHT, LLDIM, 'IRIGHT', 'ALCLLA') - CALL ALLOC (LBLINT, LLDIM, 'LBLINT', 'ALCLLA') + CALL ALLOC (IBEG, LLDIM, 'IBEG', 'ALCLLA') + CALL ALLOC (ILAB, LLDIM, 'ILAB', 'ALCLLA') + CALL ALLOC (ILAST, LLDIM, 'ILAST', 'ALCLLA') + CALL ALLOC (ILEFT, LLDIM, 'ILEFT', 'ALCLLA') + CALL ALLOC (IPTCSF, LLDIM, 'IPTCSF', 'ALCLLA') + CALL ALLOC (IRIGHT, LLDIM, 'IRIGHT', 'ALCLLA') + CALL ALLOC (LBLINT, LLDIM, 'LBLINT', 'ALCLLA') ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*LLDIM + NEWSIZ = 2*LLDIM ! - CALL RALLOC (IBEG, NEWSIZ, 'IBEG', 'ALCLLA') - CALL RALLOC (ILAB, NEWSIZ, 'ILAB', 'ALCLLA') - CALL RALLOC (ILAST, NEWSIZ, 'ILAST', 'ALCLLA') - CALL RALLOC (ILEFT, NEWSIZ, 'ILEFT', 'ALCLLA') - CALL RALLOC (IPTCSF, NEWSIZ, 'IPTCSF', 'ALCLLA') - CALL RALLOC (IRIGHT, NEWSIZ, 'IRIGHT', 'ALCLLA') - CALL RALLOC (LBLINT, NEWSIZ, 'LBLINT', 'ALCLLA') + CALL RALLOC (IBEG, NEWSIZ, 'IBEG', 'ALCLLA') + CALL RALLOC (ILAB, NEWSIZ, 'ILAB', 'ALCLLA') + CALL RALLOC (ILAST, NEWSIZ, 'ILAST', 'ALCLLA') + CALL RALLOC (ILEFT, NEWSIZ, 'ILEFT', 'ALCLLA') + CALL RALLOC (IPTCSF, NEWSIZ, 'IPTCSF', 'ALCLLA') + CALL RALLOC (IRIGHT, NEWSIZ, 'IRIGHT', 'ALCLLA') + CALL RALLOC (LBLINT, NEWSIZ, 'LBLINT', 'ALCLLA') ! - LLDIM = NEWSIZ + LLDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (IBEG, 'IBEG', 'ALCLLA') - CALL DALLOC (ILAB, 'ILAB', 'ALCLLA') - CALL DALLOC (ILAST, 'ILAST', 'ALCLLA') - CALL DALLOC (ILEFT, 'ILEFT', 'ALCLLA') - CALL DALLOC (IPTCSF, 'IPTCSF', 'ALCLLA') - CALL DALLOC (IRIGHT, 'IRIGHT', 'ALCLLA') - CALL DALLOC (LBLINT, 'LBLINT', 'ALCLLA') + CALL DALLOC (IBEG, 'IBEG', 'ALCLLA') + CALL DALLOC (ILAB, 'ILAB', 'ALCLLA') + CALL DALLOC (ILAST, 'ILAST', 'ALCLLA') + CALL DALLOC (ILEFT, 'ILEFT', 'ALCLLA') + CALL DALLOC (IPTCSF, 'IPTCSF', 'ALCLLA') + CALL DALLOC (IRIGHT, 'IRIGHT', 'ALCLLA') + CALL DALLOC (LBLINT, 'LBLINT', 'ALCLLA') ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCLLA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCLLA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCLLA + RETURN + END SUBROUTINE ALCLLA diff --git a/src/appl/rtransition90_mpi/alclla_I.f90 b/src/appl/rtransition90_mpi/alclla_I.f90 index 037098a5b..40cb5fe53 100644 --- a/src/appl/rtransition90_mpi/alclla_I.f90 +++ b/src/appl/rtransition90_mpi/alclla_I.f90 @@ -1,15 +1,15 @@ - MODULE alclla_I + MODULE alclla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCLLA(IBEG, ILAB, ILAST, ILEFT, IPTCS, IRIGH, LBLIN, & LLDIM, IMODE) - INTEGER, INTENT(INOUT) :: LLDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: LLDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IBEG, ILAB, ILAST, ILEFT, & IPTCS, IRIGH, LBLIN !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/alcnma.f90 b/src/appl/rtransition90_mpi/alcnma.f90 index 69813f9bb..adb4c90a2 100644 --- a/src/appl/rtransition90_mpi/alcnma.f90 +++ b/src/appl/rtransition90_mpi/alcnma.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) + SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -11,8 +11,8 @@ SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -22,58 +22,58 @@ SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NMDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: NMDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: IPTR, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NMDIM = 64 + NMDIM = 64 ! ! Allocate storage for arrays ! - CALL ALLOC (IPTR, NMDIM, 'IPTR', 'ALCNMA') - CALL ALLOC (ISLDR, NMDIM, 'ISLDR', 'ALCNMA') - CALL ALLOC (ISLDR1, NMDIM, 'ISLDR1', 'ALCNMA') - CALL ALLOC (XSLDR, NMDIM, 'XSLDR', 'ALCNMA') + CALL ALLOC (IPTR, NMDIM, 'IPTR', 'ALCNMA') + CALL ALLOC (ISLDR, NMDIM, 'ISLDR', 'ALCNMA') + CALL ALLOC (ISLDR1, NMDIM, 'ISLDR1', 'ALCNMA') + CALL ALLOC (XSLDR, NMDIM, 'XSLDR', 'ALCNMA') ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NMDIM + NEWSIZ = 2*NMDIM ! - CALL RALLOC (IPTR, NEWSIZ, 'IPTR', 'ALCNMA') - CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNMA') - CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNMA') - CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNMA') + CALL RALLOC (IPTR, NEWSIZ, 'IPTR', 'ALCNMA') + CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNMA') + CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNMA') + CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNMA') ! - NMDIM = NEWSIZ + NMDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (IPTR, 'IPTR', 'ALCNMA') - CALL DALLOC (ISLDR, 'ISLDR', 'ALCNMA') - CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNMA') - CALL DALLOC (XSLDR, 'XSLDR', 'ALCNMA') + CALL DALLOC (IPTR, 'IPTR', 'ALCNMA') + CALL DALLOC (ISLDR, 'ISLDR', 'ALCNMA') + CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNMA') + CALL DALLOC (XSLDR, 'XSLDR', 'ALCNMA') ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNMA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNMA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNMA + RETURN + END SUBROUTINE ALCNMA diff --git a/src/appl/rtransition90_mpi/alcnma_I.f90 b/src/appl/rtransition90_mpi/alcnma_I.f90 index fcb526cb3..11f866452 100644 --- a/src/appl/rtransition90_mpi/alcnma_I.f90 +++ b/src/appl/rtransition90_mpi/alcnma_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnma_I + MODULE alcnma_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNMA(IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, IMODE) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE INTEGER, DIMENSION(:), pointer :: IPTR, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR - INTEGER, INTENT(INOUT) :: NMDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: NMDIM + INTEGER, INTENT(IN) :: IMODE !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/alcnsa.f90 b/src/appl/rtransition90_mpi/alcnsa.f90 index 4d56cd2f8..8e7a720ad 100644 --- a/src/appl/rtransition90_mpi/alcnsa.f90 +++ b/src/appl/rtransition90_mpi/alcnsa.f90 @@ -1,7 +1,7 @@ !*********************************************************************** ! * SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, IMODE) + HM2, LAB, NPTR, NSDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -12,8 +12,8 @@ SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & ! Farid A. Parpia. Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -23,76 +23,76 @@ SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NSDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER :: NSDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: JJA, JJB, LAB, NPTR REAL(DOUBLE), DIMENSION(:), POINTER :: HB1, HB2, HC1, HC2, HM1, HM2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NSDIM = 1 + NSDIM = 1 ! ! Allocate storage for arrays ! - CALL ALLOC (JJA, NSDIM, 'JJA', 'ALCNSA') - CALL ALLOC (JJB, NSDIM, 'JJB', 'ALCNSA' ) - CALL ALLOC (HB1, NSDIM, 'HB1', 'ALCNSA') - CALL ALLOC (HB2, NSDIM, 'HB2', 'ALCNSA') - CALL ALLOC (HC1, NSDIM, 'HC1', 'ALCNSA') - CALL ALLOC (HC2, NSDIM, 'HC2', 'ALCNSA') - CALL ALLOC (HM1, NSDIM, 'HM1', 'ALCNSA') - CALL ALLOC (HM2, NSDIM, 'HM2', 'ALCNSA') - CALL ALLOC (LAB, NSDIM, 'LAB', 'ALCNSA' ) - CALL ALLOC (NPTR, NSDIM, 'NPTR', 'ALCNSA' ) + CALL ALLOC (JJA, NSDIM, 'JJA', 'ALCNSA') + CALL ALLOC (JJB, NSDIM, 'JJB', 'ALCNSA' ) + CALL ALLOC (HB1, NSDIM, 'HB1', 'ALCNSA') + CALL ALLOC (HB2, NSDIM, 'HB2', 'ALCNSA') + CALL ALLOC (HC1, NSDIM, 'HC1', 'ALCNSA') + CALL ALLOC (HC2, NSDIM, 'HC2', 'ALCNSA') + CALL ALLOC (HM1, NSDIM, 'HM1', 'ALCNSA') + CALL ALLOC (HM2, NSDIM, 'HM2', 'ALCNSA') + CALL ALLOC (LAB, NSDIM, 'LAB', 'ALCNSA' ) + CALL ALLOC (NPTR, NSDIM, 'NPTR', 'ALCNSA' ) ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NSDIM + NEWSIZ = 2*NSDIM ! - CALL RALLOC (JJA, NEWSIZ, 'JJA', 'ALCNSA') - CALL RALLOC (JJB, NEWSIZ, 'JJB', 'ALCNSA' ) - CALL RALLOC (HB1, NEWSIZ, 'HB1', 'ALCNSA') - CALL RALLOC (HB2, NEWSIZ, 'HB2', 'ALCNSA') - CALL RALLOC (HC1, NEWSIZ, 'HC1', 'ALCNSA') - CALL RALLOC (HC2, NEWSIZ, 'HC2', 'ALCNSA') - CALL RALLOC (HM1, NEWSIZ, 'HM1', 'ALCNSA') - CALL RALLOC (HM2, NEWSIZ, 'HM2', 'ALCNSA') - CALL RALLOC (LAB, NEWSIZ, 'LAB', 'ALCNSA' ) - CALL RALLOC (NPTR, NEWSIZ, 'NPTR', 'ALCNSA' ) + CALL RALLOC (JJA, NEWSIZ, 'JJA', 'ALCNSA') + CALL RALLOC (JJB, NEWSIZ, 'JJB', 'ALCNSA' ) + CALL RALLOC (HB1, NEWSIZ, 'HB1', 'ALCNSA') + CALL RALLOC (HB2, NEWSIZ, 'HB2', 'ALCNSA') + CALL RALLOC (HC1, NEWSIZ, 'HC1', 'ALCNSA') + CALL RALLOC (HC2, NEWSIZ, 'HC2', 'ALCNSA') + CALL RALLOC (HM1, NEWSIZ, 'HM1', 'ALCNSA') + CALL RALLOC (HM2, NEWSIZ, 'HM2', 'ALCNSA') + CALL RALLOC (LAB, NEWSIZ, 'LAB', 'ALCNSA' ) + CALL RALLOC (NPTR, NEWSIZ, 'NPTR', 'ALCNSA' ) ! - NSDIM = NEWSIZ + NSDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (JJA, 'JJA', 'ALCNSA') - CALL DALLOC (JJB, 'JJB', 'ALCNSA' ) - CALL DALLOC (HB1, 'HB1', 'ALCNSA') - CALL DALLOC (HB2, 'HB2', 'ALCNSA') - CALL DALLOC (HC1, 'HC1', 'ALCNSA') - CALL DALLOC (HC2, 'HC2', 'ALCNSA') - CALL DALLOC (HM1, 'HM1', 'ALCNSA') - CALL DALLOC (HM2, 'HM2', 'ALCNSA') - CALL DALLOC (LAB, 'LAB', 'ALCNSA' ) - CALL DALLOC (NPTR, 'NPTR', 'ALCNSA' ) + CALL DALLOC (JJA, 'JJA', 'ALCNSA') + CALL DALLOC (JJB, 'JJB', 'ALCNSA' ) + CALL DALLOC (HB1, 'HB1', 'ALCNSA') + CALL DALLOC (HB2, 'HB2', 'ALCNSA') + CALL DALLOC (HC1, 'HC1', 'ALCNSA') + CALL DALLOC (HC2, 'HC2', 'ALCNSA') + CALL DALLOC (HM1, 'HM1', 'ALCNSA') + CALL DALLOC (HM2, 'HM2', 'ALCNSA') + CALL DALLOC (LAB, 'LAB', 'ALCNSA' ) + CALL DALLOC (NPTR, 'NPTR', 'ALCNSA' ) ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNSA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNSA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNSA + RETURN + END SUBROUTINE ALCNSA diff --git a/src/appl/rtransition90_mpi/alcnsa_I.f90 b/src/appl/rtransition90_mpi/alcnsa_I.f90 index a0c23962c..a45a0cb39 100644 --- a/src/appl/rtransition90_mpi/alcnsa_I.f90 +++ b/src/appl/rtransition90_mpi/alcnsa_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnsa_I + MODULE alcnsa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNSA(JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, IMODE) + HM2, LAB, NPTR, NSDIM, IMODE) USE vast_kind_param, ONLY: DOUBLE - INTEGER :: NSDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER :: NSDIM + INTEGER, INTENT(IN) :: IMODE INTEGER, DIMENSION(:), pointer :: JJA, JJB, LAB, NPTR REAL(DOUBLE), DIMENSION(:), POINTER :: HB1, HB2, HC1, HC2, HM1, HM2 - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/alcnta.f90 b/src/appl/rtransition90_mpi/alcnta.f90 index 711fb0d5b..029050d08 100644 --- a/src/appl/rtransition90_mpi/alcnta.f90 +++ b/src/appl/rtransition90_mpi/alcnta.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) + SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) ! * ! This subprogram allocates (IMODE = 1), reallocates (IMODE = 2), * ! and deallocates (IMODE = 3) storage for certain arrays that are * @@ -11,8 +11,8 @@ SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) ! Farid A. Parpia. Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -22,55 +22,55 @@ SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NTDIM - INTEGER , INTENT(IN) :: IMODE + INTEGER :: NTDIM + INTEGER , INTENT(IN) :: IMODE INTEGER, DIMENSION(:), POINTER :: ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), POINTER :: XSLDR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ + INTEGER :: NEWSIZ !----------------------------------------------- ! - SELECT CASE (IMODE) - CASE (1) + SELECT CASE (IMODE) + CASE (1) ! ! Initial array dimension ! - NTDIM = 1 + NTDIM = 1 ! ! Allocate storage for arrays ! - CALL ALLOC (ISLDR, NTDIM, 'ISLDR', 'ALCNTA' ) - CALL ALLOC (ISLDR1, NTDIM,'ISLDR1', 'ALCNTA' ) - CALL ALLOC (XSLDR, NTDIM, 'XSLDR', 'ALCNTA' ) + CALL ALLOC (ISLDR, NTDIM, 'ISLDR', 'ALCNTA' ) + CALL ALLOC (ISLDR1, NTDIM,'ISLDR1', 'ALCNTA' ) + CALL ALLOC (XSLDR, NTDIM, 'XSLDR', 'ALCNTA' ) ! - CASE (2) + CASE (2) ! ! Double the allocation of storage for the arrays ! - NEWSIZ = 2*NTDIM + NEWSIZ = 2*NTDIM ! - CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNTA' ) - CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNTA' ) - CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNTA' ) + CALL RALLOC (ISLDR, NEWSIZ, 'ISLDR', 'ALCNTA' ) + CALL RALLOC (ISLDR1, NEWSIZ, 'ISLDR1', 'ALCNTA' ) + CALL RALLOC (XSLDR, NEWSIZ, 'XSLDR', 'ALCNTA' ) ! - NTDIM = NEWSIZ + NTDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocate the storage for the arrays ! - CALL DALLOC (ISLDR, 'ISLDR', 'ALCNTA' ) - CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNTA' ) - CALL DALLOC (XSLDR, 'XSLDR', 'ALCNTA' ) + CALL DALLOC (ISLDR, 'ISLDR', 'ALCNTA' ) + CALL DALLOC (ISLDR1, 'ISLDR1', 'ALCNTA' ) + CALL DALLOC (XSLDR, 'XSLDR', 'ALCNTA' ) ! - CASE DEFAULT + CASE DEFAULT ! - WRITE (6, *) 'ALCNTA: Invalid argument IMODE = ', IMODE - STOP + WRITE (6, *) 'ALCNTA: Invalid argument IMODE = ', IMODE + STOP ! - END SELECT + END SELECT ! - RETURN - END SUBROUTINE ALCNTA + RETURN + END SUBROUTINE ALCNTA diff --git a/src/appl/rtransition90_mpi/alcnta_I.f90 b/src/appl/rtransition90_mpi/alcnta_I.f90 index fd84a159f..86494d590 100644 --- a/src/appl/rtransition90_mpi/alcnta_I.f90 +++ b/src/appl/rtransition90_mpi/alcnta_I.f90 @@ -1,15 +1,15 @@ - MODULE alcnta_I + MODULE alcnta_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE ALCNTA(ISLDR, ISLDR1, XSLDR, NTDIM, IMODE) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE INTEGER, DIMENSION(:), POINTER :: ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), POINTER :: XSLDR - INTEGER, INTENT(INOUT) :: NTDIM - INTEGER, INTENT(IN) :: IMODE + INTEGER, INTENT(INOUT) :: NTDIM + INTEGER, INTENT(IN) :: IMODE !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/angdatampi.f90 b/src/appl/rtransition90_mpi/angdatampi.f90 index 507b4c9c8..d6a584580 100644 --- a/src/appl/rtransition90_mpi/angdatampi.f90 +++ b/src/appl/rtransition90_mpi/angdatampi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) + SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) ! * ! Checks if the angular file name(1).name(2).T is available * ! and appropriate * @@ -8,13 +8,13 @@ SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) ! Written by Per Jonsson 6 March 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE orb_C, ONLY: NCF, NW, IQA USE osc_C, ONLY: NKP, KP USE mpi_C @@ -25,66 +25,66 @@ SUBROUTINE ANGDATA(NAME, AVAIL, JKP, NFILE2) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JKP - INTEGER, INTENT(IN) :: NFILE2 - LOGICAL, INTENT(OUT) :: AVAIL - CHARACTER, INTENT(INOUT) :: NAME(2)*24 + INTEGER :: JKP + INTEGER, INTENT(IN) :: NFILE2 + LOGICAL, INTENT(OUT) :: AVAIL + CHARACTER, INTENT(INOUT) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: J1,J2,IBLKI,IBLKF,NWD,NKPD,nprocsd,myidd - LOGICAL :: FOUND - CHARACTER, DIMENSION(-9:9) :: S*2 + LOGICAL :: FOUND + CHARACTER, DIMENSION(-9:9) :: S*2 !----------------------------------------------- - - S((-9)) = '-9' - S((-8)) = '-8' - S((-7)) = '-7' - S((-6)) = '-6' - S((-5)) = '-5' - S((-4)) = '-4' - S((-3)) = '-3' - S((-2)) = '-2' - S((-1)) = '-1' - S(0) = '+0' - S(1) = '+1' - S(2) = '+2' - S(3) = '+3' - S(4) = '+4' - S(5) = '+5' - S(6) = '+6' - S(7) = '+7' - S(8) = '+8' - S(9) = '+9' - - J1 = INDEX(NAME(1),' ') - J2 = INDEX(NAME(2),' ') + + S((-9)) = '-9' + S((-8)) = '-8' + S((-7)) = '-7' + S((-6)) = '-6' + S((-5)) = '-5' + S((-4)) = '-4' + S((-3)) = '-3' + S((-2)) = '-2' + S((-1)) = '-1' + S(0) = '+0' + S(1) = '+1' + S(2) = '+2' + S(3) = '+3' + S(4) = '+4' + S(5) = '+5' + S(6) = '+6' + S(7) = '+7' + S(8) = '+8' + S(9) = '+9' + + J1 = INDEX(NAME(1),' ') + J2 = INDEX(NAME(2),' ') INQUIRE(FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(KP(JKP))//'T'& - , EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (6, *) - WRITE (6, *) ' Angular file not available' - AVAIL = .FALSE. - RETURN - ELSE + , EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (6, *) + WRITE (6, *) ' Angular file not available' + AVAIL = .FALSE. + RETURN + ELSE ! ! Open the file and check if it is appropriate for the present case ! OPEN(UNIT=NFILE2, FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(& - KP(JKP))//'T', STATUS='OLD', FORM='UNFORMATTED', POSITION='asis') - REWIND (NFILE2) + KP(JKP))//'T', STATUS='OLD', FORM='UNFORMATTED', POSITION='asis') + REWIND (NFILE2) READ (NFILE2) IBLKI,IBLKF,NWD,NKPD,nprocsd,myidd IF (.NOT.(NWD==NW .AND. NKPD==NKP & - .AND.nprocsd.EQ.nprocs.AND.myidd.EQ.myid)) THEN - WRITE (6, *) ' Angular file not appropriate' - AVAIL = .FALSE. - CLOSE(NFILE2, STATUS='DELETE') - RETURN - ELSE - REWIND (NFILE2) - WRITE (6, *) ' Angular data read from file' - AVAIL = .TRUE. - ENDIF - ENDIF - RETURN - END SUBROUTINE ANGDATA + .AND.nprocsd.EQ.nprocs.AND.myidd.EQ.myid)) THEN + WRITE (6, *) ' Angular file not appropriate' + AVAIL = .FALSE. + CLOSE(NFILE2, STATUS='DELETE') + RETURN + ELSE + REWIND (NFILE2) + WRITE (6, *) ' Angular data read from file' + AVAIL = .TRUE. + ENDIF + ENDIF + RETURN + END SUBROUTINE ANGDATA diff --git a/src/appl/rtransition90_mpi/angdatampi_I.f90 b/src/appl/rtransition90_mpi/angdatampi_I.f90 index d5d704162..e5fd8946c 100644 --- a/src/appl/rtransition90_mpi/angdatampi_I.f90 +++ b/src/appl/rtransition90_mpi/angdatampi_I.f90 @@ -1,13 +1,13 @@ - MODULE angdata_I + MODULE angdata_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE angdata (NAME, AVAIL, JKP, NFILE2) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME - LOGICAL, INTENT(OUT) :: AVAIL - INTEGER :: JKP - INTEGER, INTENT(IN) :: NFILE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE angdata (NAME, AVAIL, JKP, NFILE2) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME + LOGICAL, INTENT(OUT) :: AVAIL + INTEGER :: JKP + INTEGER, INTENT(IN) :: NFILE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/bessj.f90 b/src/appl/rtransition90_mpi/bessj.f90 index cd54a6a50..a352f16fc 100644 --- a/src/appl/rtransition90_mpi/bessj.f90 +++ b/src/appl/rtransition90_mpi/bessj.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BESSJ(W) + SUBROUTINE BESSJ(W) ! * ! This routine evaluates Bessel fuctions J K ( W*R/C ) at the grid * ! points for K=L-1,L,L+1 and stores them in the arrays BJ(..,1), * @@ -10,155 +10,155 @@ SUBROUTINE BESSJ(W) ! Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bess_C, ONLY: BJ, TC, TD USE debug_C, ONLY: LDBPR - USE grid_C + USE grid_C USE osc_C, ONLY: LK, KK, L=>LK USE DEF_C, ONLY: C, CVAC, PI IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: W + REAL(DOUBLE) , INTENT(IN) :: W !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I1, IW, NN, IEND, IPROD, I, JCHAN, J, ISWAP, MODNN4, & - JJ, JJJ, II - REAL(DOUBLE) :: EPSI, DFN, WR, WA, XBESS1, S1, SSN, SCN, SN, CN, B, SKEEP + JJ, JJJ, II + REAL(DOUBLE) :: EPSI, DFN, WR, WA, XBESS1, S1, SSN, SCN, SN, CN, B, SKEEP !----------------------------------------------- ! ! - EPSI = 1.0D-05 -! - IW = 1 - NN = L - 1 - IF (KK /= 0) THEN - IW = 2 - NN = L - ENDIF - 1 CONTINUE - IEND = 2*NN + 1 - IPROD = 1 - DO I = 1, IEND, 2 - IPROD = IPROD*I - END DO - DFN = IPROD - JCHAN = N - BJ(1,IW) = 1.0D00 - DO J = 2, N - WR = W*R(J) - WA = -WR*WR*0.5D00 - XBESS1 = 1.0D00 - S1 = 1.0D00 - DO I = 1, 4 - XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) - S1 = S1 + XBESS1 - IF (ABS(XBESS1) < ABS(S1)*EPSI) GO TO 4 - END DO - JCHAN = J - EXIT - 4 CONTINUE - BJ(J,IW) = S1*WR**NN/DFN - END DO + EPSI = 1.0D-05 +! + IW = 1 + NN = L - 1 + IF (KK /= 0) THEN + IW = 2 + NN = L + ENDIF + 1 CONTINUE + IEND = 2*NN + 1 + IPROD = 1 + DO I = 1, IEND, 2 + IPROD = IPROD*I + END DO + DFN = IPROD + JCHAN = N + BJ(1,IW) = 1.0D00 + DO J = 2, N + WR = W*R(J) + WA = -WR*WR*0.5D00 + XBESS1 = 1.0D00 + S1 = 1.0D00 + DO I = 1, 4 + XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1)) + S1 = S1 + XBESS1 + IF (ABS(XBESS1) < ABS(S1)*EPSI) GO TO 4 + END DO + JCHAN = J + EXIT + 4 CONTINUE + BJ(J,IW) = S1*WR**NN/DFN + END DO ! ! Use sin/cos expansion when power series takes longer ! than 4 terms to converge ! - IF (JCHAN < N) THEN - ISWAP = 0 - MODNN4 = MOD(NN - 1,4) + 1 - SELECT CASE (MODNN4) + IF (JCHAN < N) THEN + ISWAP = 0 + MODNN4 = MOD(NN - 1,4) + 1 + SELECT CASE (MODNN4) ! ! NN = 1, 5, 9, ... ! - CASE DEFAULT - SSN = -1.0D00 - SCN = 1.0D00 - ISWAP = 1 + CASE DEFAULT + SSN = -1.0D00 + SCN = 1.0D00 + ISWAP = 1 ! ! N = 2, 6, 10,.... ! - CASE (2) - SSN = -1.0D00 - SCN = -1.0D00 + CASE (2) + SSN = -1.0D00 + SCN = -1.0D00 ! ! NN = 3, 7, 11,... ! - CASE (3) - SSN = 1.0D00 - SCN = -1.0D00 - ISWAP = 1 + CASE (3) + SSN = 1.0D00 + SCN = -1.0D00 + ISWAP = 1 ! ! NN = 0, 4, 8,... ! - CASE (4) - SSN = 1.0D00 - SCN = 1.0D00 - END SELECT -! - 13 CONTINUE - DO J = JCHAN, N - WA = W*R(J) - IF (ISWAP <= 0) THEN - SN = SSN*SIN(WA) - CN = SCN*COS(WA) - ELSE - SN = SSN*COS(WA) - CN = SCN*SIN(WA) - ENDIF - I = -1 - S1 = 0.0D00 - I = I + 1 - I1 = I - DO I = I1, NN - IF (I == 0) THEN - B = 1.0D00/WA - ELSE - B = B*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I)/WA - ENDIF - S1 = S1 + B*SN - SKEEP = SN - SN = CN - CN = -SKEEP - END DO - BJ(J,IW) = S1 - END DO - ENDIF - IF (NN>=L + 1 .OR. KK==1) THEN + CASE (4) + SSN = 1.0D00 + SCN = 1.0D00 + END SELECT +! + 13 CONTINUE + DO J = JCHAN, N + WA = W*R(J) + IF (ISWAP <= 0) THEN + SN = SSN*SIN(WA) + CN = SCN*COS(WA) + ELSE + SN = SSN*COS(WA) + CN = SCN*SIN(WA) + ENDIF + I = -1 + S1 = 0.0D00 + I = I + 1 + I1 = I + DO I = I1, NN + IF (I == 0) THEN + B = 1.0D00/WA + ELSE + B = B*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I)/WA + ENDIF + S1 = S1 + B*SN + SKEEP = SN + SN = CN + CN = -SKEEP + END DO + BJ(J,IW) = S1 + END DO + ENDIF + IF (NN>=L + 1 .OR. KK==1) THEN ! ! Print out Bessel functions if (debug) option set ! - IF (LDBPR(16)) THEN - DO JJ = 1, 3 - JJJ = L - 2 + JJ - WRITE (99, 300) JJJ, (BJ(II,JJ),II=1,N) - END DO - ENDIF + IF (LDBPR(16)) THEN + DO JJ = 1, 3 + JJJ = L - 2 + JJ + WRITE (99, 300) JJJ, (BJ(II,JJ),II=1,N) + END DO + ENDIF ! ! All done ! ! zou - DO JJ = 1, 3 - JJJ = L - 2 + JJ - BJ(:N,JJ) = BJ(:N,JJ)*(C/CVAC)**JJJ - END DO + DO JJ = 1, 3 + JJJ = L - 2 + JJ + BJ(:N,JJ) = BJ(:N,JJ)*(C/CVAC)**JJJ + END DO ! zou - RETURN - ELSE - NN = NN + 1 - IW = IW + 1 - GO TO 1 - ENDIF + RETURN + ELSE + NN = NN + 1 + IW = IW + 1 + GO TO 1 + ENDIF ! - 300 FORMAT(/,' Bessel function of order ',I3,/(1P,7D18.10)) - RETURN + 300 FORMAT(/,' Bessel function of order ',I3,/(1P,7D18.10)) + RETURN ! - END SUBROUTINE BESSJ + END SUBROUTINE BESSJ diff --git a/src/appl/rtransition90_mpi/bessj_I.f90 b/src/appl/rtransition90_mpi/bessj_I.f90 index f5446edcf..b54d45634 100644 --- a/src/appl/rtransition90_mpi/bessj_I.f90 +++ b/src/appl/rtransition90_mpi/bessj_I.f90 @@ -1,11 +1,11 @@ - MODULE bessj_I + MODULE bessj_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE bessj (W) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: W - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE bessj (W) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: W + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/biosclmpi.f90 b/src/appl/rtransition90_mpi/biosclmpi.f90 index 4c6e011ae..85a2f9675 100644 --- a/src/appl/rtransition90_mpi/biosclmpi.f90 +++ b/src/appl/rtransition90_mpi/biosclmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - PROGRAM BIOSCL + PROGRAM BIOSCL ! * ! This program calculates the transition parameters for a * ! transition between an initial and a final state * @@ -16,35 +16,35 @@ PROGRAM BIOSCL ! and for reducing usage of CPU memory. NIST, October 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE default_C USE debug_C, ONLY: LDBPR, CUTOFF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setmc_I - USE setcon_I - USE fname_I - USE mrgcsl_I - USE setcslm_I - USE getosd_I - USE strsum_I - USE factt_I - USE oscl_I + USE getyn_I + USE setmc_I + USE setcon_I + USE fname_I + USE mrgcsl_I + USE setcslm_I + USE getosd_I + USE strsum_I + USE factt_I + USE oscl_I USE mpi_C IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NTEST,NCOUNT1,ILBL,lenperm,lentmp, iii - LOGICAL :: YES + LOGICAL :: YES CHARACTER, DIMENSION(2) :: NAME*24 CHARACTER, DIMENSION(2) :: FULLNAME*128 CHARACTER(LEN=3) :: idstring @@ -53,7 +53,7 @@ PROGRAM BIOSCL ! !======================================================================= ! Start mpi --- get processor info: myid, nprocs, host name; and print -!======================================================================= +!======================================================================= CALL startmpi2 (myid, nprocs, host, lenhost, ncount1, & startdir, permdir, tmpdir, 'RTRANSITION_MPI') WRITE (idstring, '(I3.3)') myid @@ -64,58 +64,58 @@ PROGRAM BIOSCL !======================================================================= ISOFILE = trim(startdir)//'/isodata' - NTEST = 1001 + NTEST = 1001 IF (myid .EQ. 0) THEN - WRITE (6, *) - WRITE (6, *) ' Default settings?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDEF = 0 - NDUMP = 1 - ELSE - NDEF = 1 - WRITE (6, *) ' Dump angular data to file?' - YES = GETYN() - IF (YES) THEN - NDUMP = 1 - ELSE - NDUMP = 0 - ENDIF - ENDIF - WRITE (6, *) - WRITE (6, *) ' Input from a CI calculation?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - INPCI = 0 - ELSE - INPCI = 1 - ENDIF + WRITE (6, *) + WRITE (6, *) ' Default settings?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDEF = 0 + NDUMP = 1 + ELSE + NDEF = 1 + WRITE (6, *) ' Dump angular data to file?' + YES = GETYN() + IF (YES) THEN + NDUMP = 1 + ELSE + NDUMP = 0 + ENDIF + ENDIF + WRITE (6, *) + WRITE (6, *) ' Input from a CI calculation?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + INPCI = 0 + ELSE + INPCI = 1 + ENDIF ENDIF !myid=0 CALL MPI_Bcast (NDEF,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (NDUMP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (INPCI,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) !Rasa -- start -!GG LDBPR = .FALSE. -! WRITE (6, *) ' Generate debug output?' -! YES = GETYN() -! WRITE (6, *) -! IF (YES) THEN -! LDBPR(18) = .TRUE. -! WRITE (6, *) ' Enter the cutoff' -! READ (5, *) CUTOFF -! ENDIF +!GG LDBPR = .FALSE. +! WRITE (6, *) ' Generate debug output?' +! YES = GETYN() +! WRITE (6, *) +! IF (YES) THEN +! LDBPR(18) = .TRUE. +! WRITE (6, *) ' Enter the cutoff' +! READ (5, *) CUTOFF +! ENDIF !Rasa -- end ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Obtain the names of the initial and final state files ! @@ -128,16 +128,16 @@ PROGRAM BIOSCL ! .csl files. These files are then merged to one file. ! !cjb print FULLNAME1= FULLNAME2= - IF (myid .EQ. 0) then + IF (myid .EQ. 0) then print*,"FULLNAME1=",FULLNAME(1) print*,"FULLNAME2=",FULLNAME(2) end if - CALL MRGCSL (FULLNAME) + CALL MRGCSL (FULLNAME) ! ! Open, check, load data from, and close, the merged .csl file ! - CALL SETCSLM + CALL SETCSLM ! ! Read mixing coefficients ! @@ -154,7 +154,7 @@ PROGRAM BIOSCL ! ! Get the remaining information ! - CALL GETOSD (FULLNAME) + CALL GETOSD (FULLNAME) ! ! Open and append a summary of the inputs to the .sum file ! @@ -176,11 +176,11 @@ PROGRAM BIOSCL ! ! Set up the table of logarithms of factorials ! - CALL FACTT + CALL FACTT ! ! Proceed with the transition calculation ! - CALL OSCL (NAME,FULLNAME,tmpdir,startdir,idstring) + CALL OSCL (NAME,FULLNAME,tmpdir,startdir,idstring) ! ! Print completion message ! @@ -196,5 +196,5 @@ PROGRAM BIOSCL ncount1, 'RTRANSITION_MPI') !======================================================================= ! - STOP - END PROGRAM BIOSCL + STOP + END PROGRAM BIOSCL diff --git a/src/appl/rtransition90_mpi/brkt.f90 b/src/appl/rtransition90_mpi/brkt.f90 index 1fb2940c2..5ee214e08 100644 --- a/src/appl/rtransition90_mpi/brkt.f90 +++ b/src/appl/rtransition90_mpi/brkt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE BRKT + SUBROUTINE BRKT ! * ! This subroutine calculates the initial and final state * ! radial overlap matrix * @@ -8,13 +8,13 @@ SUBROUTINE BRKT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:56:42 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:56:42 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE grid_C USE tatb_C @@ -23,45 +23,45 @@ SUBROUTINE BRKT !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J, L - REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET - REAL(DOUBLE) :: RESULT + INTEGER :: I, J, L + REAL(DOUBLE), DIMENSION(NNNW,NNNW) :: BRAKET + REAL(DOUBLE) :: RESULT !----------------------------------------------- - + ! - DO I = 1, NWII - DO J = 1, NWFF - IF (NAKII(I) /= NAKFF(J)) CYCLE + DO I = 1, NWII + DO J = 1, NWFF + IF (NAKII(I) /= NAKFF(J)) CYCLE ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MFII(I),MFFF(J)) + MTP = MIN(MFII(I),MFFF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.D0 - DO L = 2, MTP + TA(1) = 0.D0 + DO L = 2, MTP TA(L) = (PFII(L,I)*PFFF(L,J) + QFII(L,I)*QFFF(L,J))*RP(L) - END DO + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - - BRAKET(I,J) = RESULT - + CALL QUAD (RESULT) + + BRAKET(I,J) = RESULT + ! WRITE (*,9) '<',NPII(I),NHII(I),'|',NPFF(J),NHFF(J),'> =', & -! BRAKET(I,J) - END DO - END DO +! BRAKET(I,J) + END DO + END DO ! -! 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) - - RETURN - END SUBROUTINE BRKT +! 9 FORMAT(A,I2,A,A,I2,A,A,E20.13) + + RETURN + END SUBROUTINE BRKT diff --git a/src/appl/rtransition90_mpi/brkt_I.f90 b/src/appl/rtransition90_mpi/brkt_I.f90 index 77bbd1ec6..0d5138998 100644 --- a/src/appl/rtransition90_mpi/brkt_I.f90 +++ b/src/appl/rtransition90_mpi/brkt_I.f90 @@ -1,9 +1,9 @@ - MODULE brkt_I + MODULE brkt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE brkt - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE brkt + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/connect.f90 b/src/appl/rtransition90_mpi/connect.f90 index fb2922ac4..3e8e748ad 100644 --- a/src/appl/rtransition90_mpi/connect.f90 +++ b/src/appl/rtransition90_mpi/connect.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CONNECT + SUBROUTINE CONNECT ! * ! The position of an orbital in the merged list is connected to * ! the positions in the initial and final state lists * @@ -8,20 +8,20 @@ SUBROUTINE CONNECT ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE orb_C IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! !ww INTEGER PNTRIQ @@ -30,21 +30,21 @@ SUBROUTINE CONNECT ! ! Initialize ! - NNII(:NW) = 0.D0 - NNFF(:NW) = 0.D0 + NNII(:NW) = 0.D0 + NNFF(:NW) = 0.D0 ! ! Loop over the orbitals in the merged list ! - DO I = 1, NW - DO J = 1, NWII - IF (NP(I)/=NPII(J) .OR. NAK(I)/=NAKII(J)) CYCLE - NNII(I) = J - END DO - DO J = 1, NWFF - IF (NP(I)/=NPFF(J) .OR. NAK(I)/=NAKFF(J)) CYCLE - NNFF(I) = J - END DO - END DO - - RETURN - END SUBROUTINE CONNECT + DO I = 1, NW + DO J = 1, NWII + IF (NP(I)/=NPII(J) .OR. NAK(I)/=NAKII(J)) CYCLE + NNII(I) = J + END DO + DO J = 1, NWFF + IF (NP(I)/=NPFF(J) .OR. NAK(I)/=NAKFF(J)) CYCLE + NNFF(I) = J + END DO + END DO + + RETURN + END SUBROUTINE CONNECT diff --git a/src/appl/rtransition90_mpi/connect_I.f90 b/src/appl/rtransition90_mpi/connect_I.f90 index c0ca14809..54dd2daaf 100644 --- a/src/appl/rtransition90_mpi/connect_I.f90 +++ b/src/appl/rtransition90_mpi/connect_I.f90 @@ -1,9 +1,9 @@ - MODULE connect_I + MODULE connect_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE connect - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE connect + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/cpmix.f90 b/src/appl/rtransition90_mpi/cpmix.f90 index 571ea5aee..e7a25b264 100644 --- a/src/appl/rtransition90_mpi/cpmix.f90 +++ b/src/appl/rtransition90_mpi/cpmix.f90 @@ -1,13 +1,13 @@ !************************************************************************ - SUBROUTINE CPMIX(NAME, INPCI) + SUBROUTINE CPMIX(NAME, INPCI) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -16,64 +16,64 @@ SUBROUTINE CPMIX(NAME, INPCI) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INPCI + INTEGER, INTENT(IN) :: INPCI CHARACTER, INTENT(INOUT) :: NAME(2)*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IOS, NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK, IBLK, IB, & - NCF, NVEC, IATJP, IASPA, I, J + NCF, NVEC, IATJP, IASPA, I, J REAL(DOUBLE),DIMENSION(:), pointer :: EVAL, EVEC - INTEGER,DIMENSION(:), pointer :: IVEC - REAL(DOUBLE) :: EAV - CHARACTER :: G92MIX*6 + INTEGER,DIMENSION(:), pointer :: IVEC + REAL(DOUBLE) :: EAV + CHARACTER :: G92MIX*6 !----------------------------------------------- - - - - NAME(2) = TRIM(NAME(1))//'_CP' - IF (INPCI == 0) THEN + + + + NAME(2) = TRIM(NAME(1))//'_CP' + IF (INPCI == 0) THEN OPEN(UNIT=78, FILE=TRIM(NAME(2))//'.cbm', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - ELSE + 'UNKNOWN', POSITION='asis') + ELSE OPEN(UNIT=78, FILE=TRIM(NAME(2))//'.bm', FORM='UNFORMATTED', STATUS=& - 'UNKNOWN', POSITION='asis') - ENDIF - IF (INPCI == 0) THEN + 'UNKNOWN', POSITION='asis') + ENDIF + IF (INPCI == 0) THEN OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.cbm', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ELSE + 'OLD', POSITION='asis') + ELSE OPEN(UNIT=68, FILE=TRIM(NAME(1))//'.bm', FORM='UNFORMATTED', STATUS=& - 'OLD', POSITION='asis') - ENDIF - READ (68, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - WRITE (78) G92MIX - READ (68) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - WRITE (78) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - - DO IBLK = 1, NBLOCK - READ (68) IB, NCF, NVEC, IATJP, IASPA - WRITE (78) IB, NCF, NVEC, IATJP, IASPA - CALL ALLOC (EVAL, NVEC, 'EVAL', 'CPMIX') - CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'CPMIX') - CALL ALLOC (IVEC, NVEC, 'IVEC', 'CPMIX') - READ (68) (IVEC(I),I=1,NVEC) - READ (68) EAV, (EVAL(I),I=1,NVEC) - READ (68) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) - - WRITE (78) (IVEC(I),I=1,NVEC) - WRITE (78) EAV, (EVAL(I),I=1,NVEC) - WRITE (78) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) - CALL DALLOC (EVAL, 'EVAL', 'CPMIX') - CALL DALLOC (EVEC, 'EVEC', 'CPMIX') - CALL DALLOC (IVEC, 'IVEC', 'CPMIX') - END DO - NAME(2) = NAME(1) - CLOSE(68) - CLOSE(78) - RETURN - END SUBROUTINE CPMIX + 'OLD', POSITION='asis') + ENDIF + READ (68, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + WRITE (78) G92MIX + READ (68) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + WRITE (78) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + + DO IBLK = 1, NBLOCK + READ (68) IB, NCF, NVEC, IATJP, IASPA + WRITE (78) IB, NCF, NVEC, IATJP, IASPA + CALL ALLOC (EVAL, NVEC, 'EVAL', 'CPMIX') + CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'CPMIX') + CALL ALLOC (IVEC, NVEC, 'IVEC', 'CPMIX') + READ (68) (IVEC(I),I=1,NVEC) + READ (68) EAV, (EVAL(I),I=1,NVEC) + READ (68) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + + WRITE (78) (IVEC(I),I=1,NVEC) + WRITE (78) EAV, (EVAL(I),I=1,NVEC) + WRITE (78) ((EVEC(I + (J - 1)*NCF),I=1,NCF),J=1,NVEC) + CALL DALLOC (EVAL, 'EVAL', 'CPMIX') + CALL DALLOC (EVEC, 'EVEC', 'CPMIX') + CALL DALLOC (IVEC, 'IVEC', 'CPMIX') + END DO + NAME(2) = NAME(1) + CLOSE(68) + CLOSE(78) + RETURN + END SUBROUTINE CPMIX diff --git a/src/appl/rtransition90_mpi/cpmix_I.f90 b/src/appl/rtransition90_mpi/cpmix_I.f90 index 9bbd25487..68bdbee0b 100644 --- a/src/appl/rtransition90_mpi/cpmix_I.f90 +++ b/src/appl/rtransition90_mpi/cpmix_I.f90 @@ -1,11 +1,11 @@ - MODULE cpmix_I + MODULE cpmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cpmix (NAME, INPCI) - CHARACTER (LEN = 128), DIMENSION(2), INTENT(INOUT) :: NAME - INTEGER, INTENT(IN) :: INPCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE cpmix (NAME, INPCI) + CHARACTER (LEN = 128), DIMENSION(2), INTENT(INOUT) :: NAME + INTEGER, INTENT(IN) :: INPCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/csfm.f90 b/src/appl/rtransition90_mpi/csfm.f90 index bd4b1096f..b2d83a7c6 100644 --- a/src/appl/rtransition90_mpi/csfm.f90 +++ b/src/appl/rtransition90_mpi/csfm.f90 @@ -9,8 +9,8 @@ SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) ! Modified for different initial and final state orbitals * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -62,7 +62,7 @@ SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) JPAR = (IASPARFF(LEV2)+3)/2 JPARI = LABP(IPAR) JPARJ = LABP(JPAR) - + IF (LDBPR(18)) THEN WRITE (*,302) IVECFF(LEV2), JLABJ, JPARJ, IVECII(LEV1), & JLABI, JPARI diff --git a/src/appl/rtransition90_mpi/csfm_I.f90 b/src/appl/rtransition90_mpi/csfm_I.f90 index 0c7931cca..3b555e6b4 100644 --- a/src/appl/rtransition90_mpi/csfm_I.f90 +++ b/src/appl/rtransition90_mpi/csfm_I.f90 @@ -1,12 +1,12 @@ - MODULE csfm_I + MODULE csfm_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE CSFM (ASFA,ASFB,LEV1,LEV2) - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE REAL(DOUBLE), INTENT(OUT) :: asfa, asfb INTEGER, INTENT(IN) :: lev1, lev2 - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/engout1.f90 b/src/appl/rtransition90_mpi/engout1.f90 index a444ec77a..a4ea98b94 100644 --- a/src/appl/rtransition90_mpi/engout1.f90 +++ b/src/appl/rtransition90_mpi/engout1.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) + SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,56 +13,56 @@ SUBROUTINE ENGOUT1(EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: AUCM, AUEV, CCMS, FASI, FBSI USE jlabl_C, LABJ=>JLBR, LABP=>JLBP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NN - INTEGER :: MODE - INTEGER , INTENT(IN) :: K - REAL(DOUBLE) , INTENT(IN) :: EAV - INTEGER , INTENT(IN) :: JTOT(NN) - INTEGER , INTENT(IN) :: IPAR(NN) - INTEGER , INTENT(IN) :: ILEV(NN) - REAL(DOUBLE) , INTENT(IN) :: E(NN) + INTEGER , INTENT(IN) :: NN + INTEGER :: MODE + INTEGER , INTENT(IN) :: K + REAL(DOUBLE) , INTENT(IN) :: EAV + INTEGER , INTENT(IN) :: JTOT(NN) + INTEGER , INTENT(IN) :: IPAR(NN) + INTEGER , INTENT(IN) :: ILEV(NN) + REAL(DOUBLE) , INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - IF (K == 1) WRITE (24, 299) - IF (K == 2) WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM - END DO + IF (K == 1) WRITE (24, 299) + IF (K == 2) WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM + END DO ! - RETURN + RETURN ! - 299 FORMAT('Eigenenergies for the initial state list') - 300 FORMAT('Eigenenergies for the final state list') - 301 FORMAT('Level J Parity',10X,'Hartrees',18X,'Kaysers') - 302 FORMAT(1I3,4X,2A4,1P,2D25.15) - 303 FORMAT('Energy of each level relative to immediately lower',' level:') - 304 FORMAT('Energy of each level relative to lowest level:') - RETURN + 299 FORMAT('Eigenenergies for the initial state list') + 300 FORMAT('Eigenenergies for the final state list') + 301 FORMAT('Level J Parity',10X,'Hartrees',18X,'Kaysers') + 302 FORMAT(1I3,4X,2A4,1P,2D25.15) + 303 FORMAT('Energy of each level relative to immediately lower',' level:') + 304 FORMAT('Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUT1 + END SUBROUTINE ENGOUT1 diff --git a/src/appl/rtransition90_mpi/engout1_I.f90 b/src/appl/rtransition90_mpi/engout1_I.f90 index 04de7a381..85abe94a0 100644 --- a/src/appl/rtransition90_mpi/engout1_I.f90 +++ b/src/appl/rtransition90_mpi/engout1_I.f90 @@ -1,19 +1,19 @@ - MODULE engout1_I + MODULE engout1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE engout1 (EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT - INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER :: MODE + SUBROUTINE engout1 (EAV, E, JTOT, IPAR, ILEV, NN, MODE, K) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT + INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER :: MODE !VAST...Dummy argument MODE is not referenced in this routine. - INTEGER, INTENT(IN) :: K - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: K + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/fname.f90 b/src/appl/rtransition90_mpi/fname.f90 index e16266943..b8cd8d68c 100644 --- a/src/appl/rtransition90_mpi/fname.f90 +++ b/src/appl/rtransition90_mpi/fname.f90 @@ -1,49 +1,49 @@ !*********************************************************************** ! * - SUBROUTINE FNAME(NAME) + SUBROUTINE FNAME(NAME) ! * ! Determines the name of the initial and final states * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: NAME(2)*24 + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! ! ! Obtain the names of the initial and final state files ! - 1 CONTINUE - WRITE (6, *) ' Name of the Initial state' - READ (*, '(A)') NAME(1) - WRITE (6, *) ' Name of the Final state' - READ (*, '(A)') NAME(2) + 1 CONTINUE + WRITE (6, *) ' Name of the Initial state' + READ (*, '(A)') NAME(1) + WRITE (6, *) ' Name of the Final state' + READ (*, '(A)') NAME(2) ! - J = INDEX(NAME(1),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF + J = INDEX(NAME(1),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF ! - J = INDEX(NAME(2),' ') - IF (J == 1) THEN - WRITE (6, *) ' Names may not start with blanks' - GO TO 1 - ENDIF - - RETURN - END SUBROUTINE FNAME + J = INDEX(NAME(2),' ') + IF (J == 1) THEN + WRITE (6, *) ' Names may not start with blanks' + GO TO 1 + ENDIF + + RETURN + END SUBROUTINE FNAME diff --git a/src/appl/rtransition90_mpi/fname_I.f90 b/src/appl/rtransition90_mpi/fname_I.f90 index 9e4149e7f..0bb6379c6 100644 --- a/src/appl/rtransition90_mpi/fname_I.f90 +++ b/src/appl/rtransition90_mpi/fname_I.f90 @@ -1,11 +1,11 @@ - MODULE fname_I + MODULE fname_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE fname (NAME) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + SUBROUTINE fname (NAME) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/getosdmpi.f90 b/src/appl/rtransition90_mpi/getosdmpi.f90 index 1da3f0201..dd39bf610 100644 --- a/src/appl/rtransition90_mpi/getosdmpi.f90 +++ b/src/appl/rtransition90_mpi/getosdmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETOSD(NAME) + SUBROUTINE GETOSD(NAME) ! * ! Interactively determines the data governing the transition prob- * ! lem. * @@ -8,11 +8,11 @@ SUBROUTINE GETOSD(NAME) ! Written by Per Jonsson Last revision: June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW, NNNP @@ -27,14 +27,14 @@ SUBROUTINE GETOSD(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE getrmp_I - USE setqic_I - USE radgrd_I - USE lodrwfi_I - USE lodrwff_I - USE brkt_I + USE getyn_I + USE setiso_I + USE getrmp_I + USE setqic_I + USE radgrd_I + USE lodrwfi_I + USE lodrwff_I + USE brkt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -43,9 +43,9 @@ SUBROUTINE GETOSD(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - LOGICAL :: YES - CHARACTER :: CUNITS*4, ANSWER + INTEGER :: I + LOGICAL :: YES + CHARACTER :: CUNITS*4, ANSWER !----------------------------------------------- ! ! Determine the physical effects specifications @@ -68,129 +68,129 @@ SUBROUTINE GETOSD(NAME) C = CVAC ENDIF ! - LFORDR = .FALSE. - ICCUT = 0 + LFORDR = .FALSE. + ICCUT = 0 ! ! Determine the multipolarity and parity of the transitions ! - CALL GETRMP + CALL GETRMP ! ! Determine the units for the printout and other options ! - LTC = .FALSE. + LTC = .FALSE. ! - IF (NDEF /= 0) THEN + IF (NDEF /= 0) THEN IF (myid .EQ.0) THEN - WRITE (6, *) 'Which units are to be used to' - WRITE (6, *) ' express the transition energies?' - WRITE (6, *) ' A : Angstrom:' - WRITE (6, *) ' eV : electron volts;' - WRITE (6, *) ' Hart : Hartree atomic units;' - WRITE (6, *) ' Hz : Hertz;' - WRITE (6, *) ' Kays : Kaysers [cm**(-1)];' - 2 CONTINUE - READ (*, '(A)') CUNITS - IF (CUNITS(1:1) == 'A') THEN - LTC(1) = .TRUE. - ELSE IF (CUNITS(1:2) == 'eV') THEN - LTC(2) = .TRUE. - ELSE IF (CUNITS(1:4) == 'Hart') THEN - LTC(3) = .TRUE. - ELSE IF (CUNITS(1:2) == 'Hz') THEN - LTC(4) = .TRUE. - ELSE IF (CUNITS(1:4) == 'Kays') THEN - LTC(5) = .TRUE. - ELSE - WRITE (6, *) 'GETOSD: Unable to interpret string;' - WRITE (6, *) ' reenter ...' - GO TO 2 + WRITE (6, *) 'Which units are to be used to' + WRITE (6, *) ' express the transition energies?' + WRITE (6, *) ' A : Angstrom:' + WRITE (6, *) ' eV : electron volts;' + WRITE (6, *) ' Hart : Hartree atomic units;' + WRITE (6, *) ' Hz : Hertz;' + WRITE (6, *) ' Kays : Kaysers [cm**(-1)];' + 2 CONTINUE + READ (*, '(A)') CUNITS + IF (CUNITS(1:1) == 'A') THEN + LTC(1) = .TRUE. + ELSE IF (CUNITS(1:2) == 'eV') THEN + LTC(2) = .TRUE. + ELSE IF (CUNITS(1:4) == 'Hart') THEN + LTC(3) = .TRUE. + ELSE IF (CUNITS(1:2) == 'Hz') THEN + LTC(4) = .TRUE. + ELSE IF (CUNITS(1:4) == 'Kays') THEN + LTC(5) = .TRUE. + ELSE + WRITE (6, *) 'GETOSD: Unable to interpret string;' + WRITE (6, *) ' reenter ...' + GO TO 2 ENDIF ENDIF !myid=0 CALL MPI_Bcast(LTC(1),5,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - ELSE - LTC(5) = .TRUE. - ENDIF + ELSE + LTC(5) = .TRUE. + ENDIF ! -! WRITE (6, *) 'Sort transitions by energy?' -! YES = GETYN() -! IF (YES) LTC(6) = .TRUE. +! WRITE (6, *) 'Sort transitions by energy?' +! YES = GETYN() +! IF (YES) LTC(6) = .TRUE. ! - IF (NDEF /= 0) THEN + IF (NDEF /= 0) THEN IF (myid .EQ. 0) THEN - WRITE (6, *) 'Einstein A and B coefficients are' - WRITE (6, *) ' printed in SI units; use Hartree' - WRITE (6, *) ' atomic units instead?' - YES = GETYN() - IF (YES) LTC(7) = .TRUE. + WRITE (6, *) 'Einstein A and B coefficients are' + WRITE (6, *) ' printed in SI units; use Hartree' + WRITE (6, *) ' atomic units instead?' + YES = GETYN() + IF (YES) LTC(7) = .TRUE. ENDIF !myid=0 CALL MPI_Bcast(LTC(7),1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) - ELSE - LTC(7) = .FALSE. - ENDIF + ELSE + LTC(7) = .FALSE. + ENDIF ! ! Determine the parameters controlling the radial grid ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF ... should be Z-dependent RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN IF (myid .EQ. 0) THEN - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF ENDIF !myid=0 CALL MPI_Bcast(RNT,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast(H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast(HP,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast (N, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical proceduRes ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Load the initial state radial wavefunctions. ! - CALL LODRWFI (NAME(1)) + CALL LODRWFI (NAME(1)) ! ! Load the final state radial wavefunctions. ! - CALL LODRWFF (NAME(2)) - + CALL LODRWFF (NAME(2)) + ! Construct the radial overlap matrix. ! - CALL BRKT - - RETURN - END SUBROUTINE GETOSD + CALL BRKT + + RETURN + END SUBROUTINE GETOSD diff --git a/src/appl/rtransition90_mpi/getosdmpi_I.f90 b/src/appl/rtransition90_mpi/getosdmpi_I.f90 index 4123694da..3a84c8381 100644 --- a/src/appl/rtransition90_mpi/getosdmpi_I.f90 +++ b/src/appl/rtransition90_mpi/getosdmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE getosd_I + MODULE getosd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getosd (NAME) - CHARACTER (LEN = 128), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getosd (NAME) + CHARACTER (LEN = 128), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/getrmpmpi.f90 b/src/appl/rtransition90_mpi/getrmpmpi.f90 index 466be04ec..203d9d7fd 100644 --- a/src/appl/rtransition90_mpi/getrmpmpi.f90 +++ b/src/appl/rtransition90_mpi/getrmpmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETRMP + SUBROUTINE GETRMP ! * ! Interactively determines the list of radiation multipolarities * ! and parities. This is loadad into COMMON/OSC6/. * @@ -10,142 +10,142 @@ SUBROUTINE GETRMP ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man - USE OFFD_C + USE OFFD_C USE osc_C, ONLY: NKP, KP USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I + USE getyn_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NDKP, ISTART, I, IEND, LENTH, IOS, MULT - REAL, DIMENSION(3) :: CNUM - LOGICAL :: LELEC, LMAGN, YES - CHARACTER :: RECORD*256, RECI + INTEGER :: NDKP, ISTART, I, IEND, LENTH, IOS, MULT + REAL, DIMENSION(3) :: CNUM + LOGICAL :: LELEC, LMAGN, YES + CHARACTER :: RECORD*256, RECI !----------------------------------------------- ! ! ! Initial allocation for PNTRKP ! - NDKP = 1 - CALL ALLOC (KP, NDKP, 'KP', 'GETRMP' ) + NDKP = 1 + CALL ALLOC (KP, NDKP, 'KP', 'GETRMP' ) IF (myid .EQ. 0) THEN ! ! Entry message ! - 1 CONTINUE - WRITE (6, *) 'Enter the list of transition specifications' - WRITE (6, *) ' e.g., E1,M2 or E1 M2 or E1;M2 :' + 1 CONTINUE + WRITE (6, *) 'Enter the list of transition specifications' + WRITE (6, *) ' e.g., E1,M2 or E1 M2 or E1;M2 :' ! ! Initialise NKP ! - 2 CONTINUE - READ (*, '(A)') RECORD - NKP = 0 + 2 CONTINUE + READ (*, '(A)') RECORD + NKP = 0 ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - 3 CONTINUE - RECI = RECORD(I:I) - IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN - IF (ISTART == 0) ISTART = I - ELSE - IF (ISTART /= 0) THEN - IEND = I - 1 - RECI = RECORD(ISTART:ISTART) - IF (RECI == 'E') THEN - LELEC = .TRUE. - LMAGN = .FALSE. - ELSE IF (RECI == 'M') THEN - LELEC = .FALSE. - LMAGN = .TRUE. - ELSE - WRITE (6, *) 'GETRMP: Transitions must be of type' - WRITE (6, *) ' E or type M; reenter ...' - GO TO 2 - ENDIF - LENTH = IEND - ISTART - IF (LENTH /= 1) THEN - WRITE (6, *) 'GETRMP: Transition multipolarities' - WRITE (6, *) ' must be integers between 1 and 9;' - WRITE (6, *) ' reenter ...' - GO TO 2 - ENDIF - RECI = RECORD(IEND:IEND) - READ (RECI, '(1I1)', IOSTAT=IOS) MULT - IF (IOS /= 0) THEN - WRITE (6, *) 'GETRMP: Unable to decode multipolarity' - WRITE (6, *) ' '//RECI//'; reenter ...' - GO TO 2 - ENDIF - NKP = NKP + 1 - IF (NKP > NDKP) THEN - CALL RALLOC (KP, NKP, 'KP', 'GETRMP' ) - NDKP = NKP - ENDIF - IF (LELEC) THEN - KP(NKP) = MULT*(-1)**MULT - ELSE IF (LMAGN) THEN - KP(NKP) = MULT*(-1)**(MULT + 1) - ENDIF - ISTART = 0 - ENDIF - ENDIF -! - IF (I < 256) THEN - I = I + 1 - GO TO 3 - ENDIF -! - IF (NKP == 0) GO TO 1 + ISTART = 0 + I = 1 + 3 CONTINUE + RECI = RECORD(I:I) + IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN + IF (ISTART == 0) ISTART = I + ELSE + IF (ISTART /= 0) THEN + IEND = I - 1 + RECI = RECORD(ISTART:ISTART) + IF (RECI == 'E') THEN + LELEC = .TRUE. + LMAGN = .FALSE. + ELSE IF (RECI == 'M') THEN + LELEC = .FALSE. + LMAGN = .TRUE. + ELSE + WRITE (6, *) 'GETRMP: Transitions must be of type' + WRITE (6, *) ' E or type M; reenter ...' + GO TO 2 + ENDIF + LENTH = IEND - ISTART + IF (LENTH /= 1) THEN + WRITE (6, *) 'GETRMP: Transition multipolarities' + WRITE (6, *) ' must be integers between 1 and 9;' + WRITE (6, *) ' reenter ...' + GO TO 2 + ENDIF + RECI = RECORD(IEND:IEND) + READ (RECI, '(1I1)', IOSTAT=IOS) MULT + IF (IOS /= 0) THEN + WRITE (6, *) 'GETRMP: Unable to decode multipolarity' + WRITE (6, *) ' '//RECI//'; reenter ...' + GO TO 2 + ENDIF + NKP = NKP + 1 + IF (NKP > NDKP) THEN + CALL RALLOC (KP, NKP, 'KP', 'GETRMP' ) + NDKP = NKP + ENDIF + IF (LELEC) THEN + KP(NKP) = MULT*(-1)**MULT + ELSE IF (LMAGN) THEN + KP(NKP) = MULT*(-1)**(MULT + 1) + ENDIF + ISTART = 0 + ENDIF + ENDIF +! + IF (I < 256) THEN + I = I + 1 + GO TO 3 + ENDIF +! + IF (NKP == 0) GO TO 1 ENDIF !myid=0 CALL MPI_Bcast(NKP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) ! ! Trim array to the exact size ! - IF (NDKP /= NKP) CALL RALLOC (KP, NKP, 'KP', 'GETRMP') + IF (NDKP /= NKP) CALL RALLOC (KP, NKP, 'KP', 'GETRMP') CALL MPI_Bcast(KP(1),NKP,MPI_INTEGER,0,MPI_COMM_WORLD, ierr) ! ! If M1 or E2 inquire if the transitions are between levels ! with different J quantum numbers. ! IF(myid == 0) THEN - DO I = 1, NKP - IF (KP(I) == 1) THEN + DO I = 1, NKP + IF (KP(I) == 1) THEN WRITE (*, *) & - 'M1 transitions only between levels with different J?' - YES = GETYN() - IF (YES) THEN - NOFFD1 = 1 - ELSE - NOFFD1 = 0 - ENDIF - ENDIF - IF (KP(I) /= 2) CYCLE + 'M1 transitions only between levels with different J?' + YES = GETYN() + IF (YES) THEN + NOFFD1 = 1 + ELSE + NOFFD1 = 0 + ENDIF + ENDIF + IF (KP(I) /= 2) CYCLE WRITE (*, *) & - 'E2 transitions only between levels with different J?' - YES = GETYN() - IF (YES) THEN - NOFFD2 = 1 - ELSE - NOFFD2 = 0 - ENDIF - END DO + 'E2 transitions only between levels with different J?' + YES = GETYN() + IF (YES) THEN + NOFFD2 = 1 + ELSE + NOFFD2 = 0 + ENDIF + END DO ENDIF !myid=0 CALL MPI_Bcast(NOFFD1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) CALL MPI_Bcast(NOFFD2,1,MPI_INTEGER,0,MPI_COMM_WORLD, ierr) ! - RETURN - END SUBROUTINE GETRMP + RETURN + END SUBROUTINE GETRMP diff --git a/src/appl/rtransition90_mpi/getrmpmpi_I.f90 b/src/appl/rtransition90_mpi/getrmpmpi_I.f90 index e72269a88..24dd537a2 100644 --- a/src/appl/rtransition90_mpi/getrmpmpi_I.f90 +++ b/src/appl/rtransition90_mpi/getrmpmpi_I.f90 @@ -1,9 +1,9 @@ - MODULE getrmp_I + MODULE getrmp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getrmp - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getrmp + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/iqr.f90 b/src/appl/rtransition90_mpi/iqr.f90 index 73d6ab7c1..3583c7b14 100644 --- a/src/appl/rtransition90_mpi/iqr.f90 +++ b/src/appl/rtransition90_mpi/iqr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION IQR (ISUBSH, ICSF) + INTEGER FUNCTION IQR (ISUBSH, ICSF) ! * ! IQR is the occupation of subshell ISUBSH in CSF ICSF. * ! * @@ -8,8 +8,8 @@ INTEGER FUNCTION IQR (ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -19,12 +19,12 @@ INTEGER FUNCTION IQR (ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! ! IQR = IQA(isubsh,icsf) ! - RETURN - END FUNCTION IQR + RETURN + END FUNCTION IQR diff --git a/src/appl/rtransition90_mpi/iqr_I.f90 b/src/appl/rtransition90_mpi/iqr_I.f90 index d2c32bd64..d8f77a112 100644 --- a/src/appl/rtransition90_mpi/iqr_I.f90 +++ b/src/appl/rtransition90_mpi/iqr_I.f90 @@ -1,11 +1,11 @@ - MODULE iqr_I + MODULE iqr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION iqr (ISUBSH, ICSF) - INTEGER, INTENT(IN) :: ISUBSH - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION iqr (ISUBSH, ICSF) + INTEGER, INTENT(IN) :: ISUBSH + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/isparr.f90 b/src/appl/rtransition90_mpi/isparr.f90 index d83e5dcdc..c9834dcbb 100644 --- a/src/appl/rtransition90_mpi/isparr.f90 +++ b/src/appl/rtransition90_mpi/isparr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ISPARR (ICSF) + INTEGER FUNCTION ISPARR (ICSF) ! * ! ISPARR is the value of P for CSF number ICSF. * ! * @@ -10,8 +10,8 @@ INTEGER FUNCTION ISPARR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -27,21 +27,21 @@ INTEGER FUNCTION ISPARR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! ! - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN isparr = jcupar(NNNW,icsf) - IF (ISPARR > 127) ISPARR = ISPARR - 256 - ISPARR = SIGN(1,ISPARR) - ELSE - WRITE (6, *) 'ISPARR: Argument ICSF is out of range.' - STOP - ENDIF + IF (ISPARR > 127) ISPARR = ISPARR - 256 + ISPARR = SIGN(1,ISPARR) + ELSE + WRITE (6, *) 'ISPARR: Argument ICSF is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION ISPARR + RETURN + END FUNCTION ISPARR diff --git a/src/appl/rtransition90_mpi/isparr_I.f90 b/src/appl/rtransition90_mpi/isparr_I.f90 index 273e7a7a0..85f836870 100644 --- a/src/appl/rtransition90_mpi/isparr_I.f90 +++ b/src/appl/rtransition90_mpi/isparr_I.f90 @@ -1,10 +1,10 @@ - MODULE isparr_I + MODULE isparr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION isparr (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION isparr (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/itjpor.f90 b/src/appl/rtransition90_mpi/itjpor.f90 index 18a7dc209..479ce6bf4 100644 --- a/src/appl/rtransition90_mpi/itjpor.f90 +++ b/src/appl/rtransition90_mpi/itjpor.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITJPOR (ICSF) + INTEGER FUNCTION ITJPOR (ICSF) ! * ! ITJPOR is the value of 2J+1 for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ITJPOR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPAR @@ -25,17 +25,17 @@ INTEGER FUNCTION ITJPOR (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN itjpor = jcupar(NNNW,icsf) - IF (ITJPOR > 127) ITJPOR = 256 - ITJPOR + IF (ITJPOR > 127) ITJPOR = 256 - ITJPOR ITJPOR = IABS (ITJPOR) - ELSE - WRITE (6, *) 'ITJPOR: Argument ICSF is out of range.' - STOP - ENDIF + ELSE + WRITE (6, *) 'ITJPOR: Argument ICSF is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION ITJPOR + RETURN + END FUNCTION ITJPOR diff --git a/src/appl/rtransition90_mpi/itjpor_I.f90 b/src/appl/rtransition90_mpi/itjpor_I.f90 index 8422a1047..0125b7437 100644 --- a/src/appl/rtransition90_mpi/itjpor_I.f90 +++ b/src/appl/rtransition90_mpi/itjpor_I.f90 @@ -1,10 +1,10 @@ - MODULE itjpor_I + MODULE itjpor_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itjpor (ICSF) - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION itjpor (ICSF) + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/jcupr.f90 b/src/appl/rtransition90_mpi/jcupr.f90 index 65ebd2a4f..8f640efb3 100644 --- a/src/appl/rtransition90_mpi/jcupr.f90 +++ b/src/appl/rtransition90_mpi/jcupr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION JCUPR (LOC, ICSF) + INTEGER FUNCTION JCUPR (LOC, ICSF) ! * ! JCUPR is the 2J+1 value of the LOCth nontrivial intermediate ang- * ! ular momentum in CSF ICSF. * @@ -9,11 +9,11 @@ INTEGER FUNCTION JCUPR (LOC, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW use orb_C, ONLY: NWR, NCFR @@ -25,21 +25,21 @@ INTEGER FUNCTION JCUPR (LOC, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: LOC - INTEGER :: ICSF + INTEGER , INTENT(IN) :: LOC + INTEGER :: ICSF !----------------------------------------------- ! - IF (LOC>=1 .AND. LOC<=NWR-1) THEN - IF (ICSF>=1 .AND. ICSF<=NCFR) THEN + IF (LOC>=1 .AND. LOC<=NWR-1) THEN + IF (ICSF>=1 .AND. ICSF<=NCFR) THEN jcupr = jcupar(loc,icsf) - ELSE - WRITE (6, *) 'JCUPR: Argument ICSF is out of range.' - STOP - ENDIF - ELSE - WRITE (6, *) 'JCUPR: Argument LOC is out of range.' - STOP - ENDIF + ELSE + WRITE (6, *) 'JCUPR: Argument ICSF is out of range.' + STOP + ENDIF + ELSE + WRITE (6, *) 'JCUPR: Argument LOC is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION JCUPR + RETURN + END FUNCTION JCUPR diff --git a/src/appl/rtransition90_mpi/jcupr_I.f90 b/src/appl/rtransition90_mpi/jcupr_I.f90 index 18f6f24c3..36b302349 100644 --- a/src/appl/rtransition90_mpi/jcupr_I.f90 +++ b/src/appl/rtransition90_mpi/jcupr_I.f90 @@ -1,11 +1,11 @@ - MODULE jcupr_I + MODULE jcupr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jcupr (LOC, ICSF) - INTEGER, INTENT(IN) :: LOC - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION jcupr (LOC, ICSF) + INTEGER, INTENT(IN) :: LOC + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/jqsr.f90 b/src/appl/rtransition90_mpi/jqsr.f90 index 3e905be0f..affcce8b5 100644 --- a/src/appl/rtransition90_mpi/jqsr.f90 +++ b/src/appl/rtransition90_mpi/jqsr.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) + INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) ! * ! JQSR is a subshell quantum number for subshell ISUBSH in configu- * ! ration state function ICSF: the seniority if IWHICH is 1; the * @@ -11,11 +11,11 @@ INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JQSAR @@ -27,12 +27,12 @@ INTEGER FUNCTION JQSR (IWHICH, ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! jqsr = jqsar(isubsh,iwhich,icsf) ! - RETURN - END FUNCTION JQSR + RETURN + END FUNCTION JQSR diff --git a/src/appl/rtransition90_mpi/jqsr_I.f90 b/src/appl/rtransition90_mpi/jqsr_I.f90 index 895b642fb..5026e5bd8 100644 --- a/src/appl/rtransition90_mpi/jqsr_I.f90 +++ b/src/appl/rtransition90_mpi/jqsr_I.f90 @@ -1,12 +1,12 @@ - MODULE jqsr_I + MODULE jqsr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jqsr (IWHICH, ISUBSH, ICSF) - INTEGER, INTENT(IN) :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER, INTENT(IN) :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION jqsr (IWHICH, ISUBSH, ICSF) + INTEGER, INTENT(IN) :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER, INTENT(IN) :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/ldcsl1mpi.f90 b/src/appl/rtransition90_mpi/ldcsl1mpi.f90 index 6550864c5..4b4fa03c0 100644 --- a/src/appl/rtransition90_mpi/ldcsl1mpi.f90 +++ b/src/appl/rtransition90_mpi/ldcsl1mpi.f90 @@ -9,7 +9,7 @@ SUBROUTINE LDCSL1 (NCORER,NAME) ! * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -44,7 +44,7 @@ SUBROUTINE LDCSL1 (NCORER,NAME) J = INDEX(NAME,' ') OPEN (UNIT = 21,FILE=NAME(1:J-1)//'.c',FORM='FORMATTED', & & STATUS='OLD') - + READ (21,'(1A15)',IOSTAT = IOS) RECORD IF ((IOS .NE. 0) .OR. & & (RECORD(1:15) .NE. 'Core subshells:')) THEN @@ -117,6 +117,6 @@ SUBROUTINE LDCSL1 (NCORER,NAME) CALL DALLOC (JCUPA, 'JCUPA', 'LDCSL1') ! CLOSE (21) - + RETURN END diff --git a/src/appl/rtransition90_mpi/ldcsl1mpi_I.f90 b/src/appl/rtransition90_mpi/ldcsl1mpi_I.f90 index 6eb696659..853476086 100644 --- a/src/appl/rtransition90_mpi/ldcsl1mpi_I.f90 +++ b/src/appl/rtransition90_mpi/ldcsl1mpi_I.f90 @@ -1,10 +1,10 @@ - MODULE ldcsl1_I + MODULE ldcsl1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDCSL1 (NCORER,NAME) INTEGER :: ncorer CHARACTER(LEN=128) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/ldcsl2mpi.f90 b/src/appl/rtransition90_mpi/ldcsl2mpi.f90 index 4defeab9e..e58f8de81 100644 --- a/src/appl/rtransition90_mpi/ldcsl2mpi.f90 +++ b/src/appl/rtransition90_mpi/ldcsl2mpi.f90 @@ -1,8 +1,8 @@ !*********************************************************************** ! * - SUBROUTINE LDCSL2(NCORE, NAME) + SUBROUTINE LDCSL2(NCORE, NAME) !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- ! * ! Open, check, load data from and close the .csl file. This file * @@ -13,31 +13,31 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C USE orb_C USE biorb_C - + !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lodcsl_I + USE lodcsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(OUT) :: NCORE + INTEGER , INTENT(OUT) :: NCORE CHARACTER , INTENT(IN) :: NAME*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, IOS, NCORER, I - CHARACTER :: RECORD*15 + INTEGER :: J, IOS, NCORER, I + CHARACTER :: RECORD*15 !----------------------------------------------- ! ! @@ -46,30 +46,30 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! ! The .csl file is FORMATTED; it must exist ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=21, FILE=NAME(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - STOP - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + STOP + ENDIF ! ! Load data from the .csl file ! - CALL LODCSL (NCORER) + CALL LODCSL (NCORER) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! ! Check if the core should be redefined ! - NCORE = NCORER + NCORE = NCORER ! DO 3 I = NCORER+1,NW ! IFULLI = NKJ(I)+1 ! DO 2 J = 1,NCF @@ -82,13 +82,13 @@ SUBROUTINE LDCSL2(NCORE, NAME) ! NCORE = NCORE+1 ! 3 CONTINUE ! - NELECFF = NELEC - NWFF = NW - NCFFF = NCF - NHFF(:NW) = NH(:NW) - NPFF(:NW) = NP(:NW) - NAKFF(:NW) = NAK(:NW) - NKLFF(:NW) = NKL(:NW) - NKJFF(:NW) = NKJ(:NW) - RETURN - END SUBROUTINE LDCSL2 + NELECFF = NELEC + NWFF = NW + NCFFF = NCF + NHFF(:NW) = NH(:NW) + NPFF(:NW) = NP(:NW) + NAKFF(:NW) = NAK(:NW) + NKLFF(:NW) = NKL(:NW) + NKJFF(:NW) = NKJ(:NW) + RETURN + END SUBROUTINE LDCSL2 diff --git a/src/appl/rtransition90_mpi/ldcsl2mpi_I.f90 b/src/appl/rtransition90_mpi/ldcsl2mpi_I.f90 index fcc5674e6..90797bed2 100644 --- a/src/appl/rtransition90_mpi/ldcsl2mpi_I.f90 +++ b/src/appl/rtransition90_mpi/ldcsl2mpi_I.f90 @@ -1,10 +1,10 @@ - MODULE ldcsl2_I + MODULE ldcsl2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ldcsl2 (NCORE, NAME) - INTEGER, INTENT(OUT) :: NCORE - CHARACTER (LEN = 128), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE ldcsl2 (NCORE, NAME) + INTEGER, INTENT(OUT) :: NCORE + CHARACTER (LEN = 128), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/ldlbl1.f90 b/src/appl/rtransition90_mpi/ldlbl1.f90 index ffb405d90..6f1cc75ec 100644 --- a/src/appl/rtransition90_mpi/ldlbl1.f90 +++ b/src/appl/rtransition90_mpi/ldlbl1.f90 @@ -11,7 +11,7 @@ SUBROUTINE LDLBL1 (NAME) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s @@ -50,7 +50,7 @@ SUBROUTINE LDLBL1 (NAME) CALL ALLOC (RLev_ENER_1,NVECTOTI,'RLev_ENER_1','LDLBL1') !CPJ CALL ALLOC (string_CSF1,NVECTOTI,'string_CSF1','LDLBL1') allocate(string_CSF1(1:NVECTOTI)) -! +! ICount = 1 READ (31,'(1X,I2,1X,A4,5X,A1,8X,F16.9)',IOSTAT = IOS) & diff --git a/src/appl/rtransition90_mpi/ldlbl1_I.f90 b/src/appl/rtransition90_mpi/ldlbl1_I.f90 index 82e499a4c..5708171a4 100644 --- a/src/appl/rtransition90_mpi/ldlbl1_I.f90 +++ b/src/appl/rtransition90_mpi/ldlbl1_I.f90 @@ -1,9 +1,9 @@ - MODULE ldlbl1_I + MODULE ldlbl1_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDLBL1 (NAME) CHARACTER(LEN=128) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/ldlbl2.f90 b/src/appl/rtransition90_mpi/ldlbl2.f90 index 12fd85145..e6329c70a 100644 --- a/src/appl/rtransition90_mpi/ldlbl2.f90 +++ b/src/appl/rtransition90_mpi/ldlbl2.f90 @@ -11,7 +11,7 @@ SUBROUTINE LDLBL2 (NAME) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/appl/rtransition90_mpi/ldlbl2_I.f90 b/src/appl/rtransition90_mpi/ldlbl2_I.f90 index bb48abc86..fc0149e46 100644 --- a/src/appl/rtransition90_mpi/ldlbl2_I.f90 +++ b/src/appl/rtransition90_mpi/ldlbl2_I.f90 @@ -1,9 +1,9 @@ - MODULE ldlbl2_I + MODULE ldlbl2_I INTERFACE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LDLBL2 (NAME) CHARACTER(LEN=128) :: name - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/lodcslm.f90 b/src/appl/rtransition90_mpi/lodcslm.f90 index dfccb1f71..91075afe1 100644 --- a/src/appl/rtransition90_mpi/lodcslm.f90 +++ b/src/appl/rtransition90_mpi/lodcslm.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSLM(NCORE) + SUBROUTINE LODCSLM(NCORE) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -10,125 +10,125 @@ SUBROUTINE LODCSLM(NCORE) ! To accept both block and non-block formats ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE memory_man USE debug_C USE def_C USE orb_C - USE STAT_C - USE TERMS_C + USE STAT_C + USE TERMS_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE + INTEGER :: NCORE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: IOCC - INTEGER , DIMENSION(NW2) :: IQSUB - INTEGER , DIMENSION(NNNW) :: JX + INTEGER , DIMENSION(NNNW) :: IOCC + INTEGER , DIMENSION(NW2) :: IQSUB + INTEGER , DIMENSION(NNNW) :: JX INTEGER :: NCORP1, NPEEL, NPEEL2, J, NPJ, NAKJ, I, LENTH, NCFD, NREC, IOS& , IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN, NJXN, NPEELN, & NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU, JSUB, IQT, NBEG, NEND, & - JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECORD*256, RECL + JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECORD*256, RECL !----------------------------------------------- ! ! ! Entry message ! -! WRITE (6, *) 'Loading Configuration Symmetry List File ...' +! WRITE (6, *) 'Loading Configuration Symmetry List File ...' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (21, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (21, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (21, *) - CALL PRSRSL (21, 2) - NPEEL = NW - NCORE - NPEEL2 = NPEEL*2 + READ (21, *) + CALL PRSRSL (21, 2) + NPEEL = NW - NCORE + NPEEL2 = NPEEL*2 ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE - WRITE (6, *) 'LODCSL: The lists of core and' - WRITE (6, *) ' peel subshells must form' - WRITE (6, *) ' disjoint sets.' - STOP - END DO - END DO + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + WRITE (6, *) 'LODCSL: The lists of core and' + WRITE (6, *) ' peel subshells must form' + WRITE (6, *) ' disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) ! WRITE (6, *) ' there are '//RECORD(1:LENTH)//& -! ' relativistic subshells;' - ELSE - WRITE (6, *) ' there is 1 relativistic subshell;' - ENDIF +! ' relativistic subshells;' + ELSE + WRITE (6, *) ' there is 1 relativistic subshell;' + ENDIF ! ! Initial allocation for arrays with a dimension dependent ! on the number of CSFs; the initial allocation must be ! greater than 1 ! - CALL DALLOC (IQA, 'IQA', 'LODCSLM') - CALL DALLOC (JQSA, 'JQSA', 'LODCSLM') - CALL DALLOC (JCUPA, 'JCUPA', 'LODCSLM') - NCFD = 2 - CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSLM') - CALL ALLOC (JQSA, NNNW, 3, NCFD, 'JQSA', 'LODCSLM') - CALL ALLOC (JCUPA, NNNW, NCFD, 'JCUPA', 'LODCSLM') + CALL DALLOC (IQA, 'IQA', 'LODCSLM') + CALL DALLOC (JQSA, 'JQSA', 'LODCSLM') + CALL DALLOC (JCUPA, 'JCUPA', 'LODCSLM') + NCFD = 2 + CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSLM') + CALL ALLOC (JQSA, NNNW, 3, NCFD, 'JQSA', 'LODCSLM') + CALL ALLOC (JCUPA, NNNW, NCFD, 'JCUPA', 'LODCSLM') ! ! Skip the header for the list of CSFs ! - READ (21, *) + READ (21, *) ! ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -160,400 +160,400 @@ SUBROUTINE LODCSLM(NCORE) ! These conventions have been chosen so as to render the CSF ! specifications easily interpreted by the user ! - NCF = 0 - 3 CONTINUE - NCF = NCF + 1 + NCF = 0 + 3 CONTINUE + NCF = NCF + 1 ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** !blk* ! To skip the border line added to mark the end of a block ! - IF (RECORD(1:2) == ' *') READ (21, '(A)', IOSTAT=IOS) RECORD + IF (RECORD(1:2) == ' *') READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** - - IF (IOS == 0) THEN + + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN - WRITE (6, *) 'LODCSL: Expecting subshell quantum' - WRITE (6, *) ' number specification;' - GO TO 26 - ENDIF - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN + WRITE (6, *) 'LODCSL: Expecting subshell quantum' + WRITE (6, *) ' number specification;' + GO TO 26 + ENDIF + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN - WRITE (6, *) 'LODCSL: Expecting intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum number and final parity' - WRITE (6, *) ' specification;' - GO TO 26 - ENDIF + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN + WRITE (6, *) 'LODCSL: Expecting intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum number and final parity' + WRITE (6, *) ' specification;' + GO TO 26 + ENDIF ! ! Allocate additional storage if necessary ! - IF (NCF > NCFD) THEN - NEWSIZ = NCFD + NCFD/2 + IF (NCF > NCFD) THEN + NEWSIZ = NCFD + NCFD/2 CALL RALLOC (IQA, NNNW, NEWSIZ, 'IQA', 'LODCSLM') CALL RALLOC (JQSA, NNNW, 3, NEWSIZ, 'JQSA', 'LODCSLM') CALL RALLOC (JCUPA, NNNW, NEWSIZ, 'JCUPA', 'LODCSLM') - NCFD = NEWSIZ - ENDIF + NCFD = NEWSIZ + ENDIF ! ! Zero out the arrays that store packed integers ! - IQA(:NNNW,NCF) = 0 - JQSA(:NNNW,1,NCF) = 0 - JQSA(:NNNW,2,NCF) = 0 - JQSA(:NNNW,3,NCF) = 0 - JCUPA(:NNNW,NCF) = 0 + IQA(:NNNW,NCF) = 0 + JQSA(:NNNW,1,NCF) = 0 + JQSA(:NNNW,2,NCF) = 0 + JQSA(:NNNW,3,NCF) = 0 + JCUPA(:NNNW,NCF) = 0 ! ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE - WRITE (6, *) 'LODCSL: Incorrect parity' - WRITE (6, *) ' specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 -! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE + WRITE (6, *) 'LODCSL: Incorrect parity' + WRITE (6, *) ' specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 +! + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN - WRITE (6, *) 'LODCSL: Too few subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) - WRITE (6, *) 'LODCSL: Subshell quantum numbers' - WRITE (6, *) ' specified incorrectly for' - WRITE (6, *) ' '//RECORD(1:LENTH)//NH(I)//' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN - WRITE (6, *) 'LODCSL: Too few intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN + WRITE (6, *) 'LODCSL: Too few subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) + WRITE (6, *) 'LODCSL: Subshell quantum numbers' + WRITE (6, *) ' specified incorrectly for' + WRITE (6, *) ' '//RECORD(1:LENTH)//NH(I)//' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN + WRITE (6, *) 'LODCSL: Too few intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I& - ) - WRITE (6, *) ' subshell to previous subshells' - WRITE (6, *) ' is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN - WRITE (6, *) 'LODCSL: Too many subshell' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF -! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN - WRITE (6, *) 'LODCSL: Too many intermediate' - WRITE (6, *) ' and final angular momentum' - WRITE (6, *) ' quantum numbers specified;' - GO TO 26 - ENDIF -! - IF (JX(NJXN) /= JLAST) THEN - WRITE (6, *) 'LODCSL: Final angular momentum' - WRITE (6, *) ' incorrectly specified;' - GO TO 26 - ENDIF -! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (6, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF -! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) -! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN - WRITE (6, *) 'LODCSL: Inconsistency in the number' - WRITE (6, *) ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ) + WRITE (6, *) ' subshell to previous subshells' + WRITE (6, *) ' is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN + WRITE (6, *) 'LODCSL: Too many subshell' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF +! + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN + WRITE (6, *) 'LODCSL: Too many intermediate' + WRITE (6, *) ' and final angular momentum' + WRITE (6, *) ' quantum numbers specified;' + GO TO 26 + ENDIF +! + IF (JX(NJXN) /= JLAST) THEN + WRITE (6, *) 'LODCSL: Final angular momentum' + WRITE (6, *) ' incorrectly specified;' + GO TO 26 + ENDIF +! + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (6, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF +! + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) +! + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN + WRITE (6, *) 'LODCSL: Inconsistency in the number' + WRITE (6, *) ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! ! print *, 'Check duplicated CSFs' - IF (NCF > 1) THEN - DO J = 1, NCF - 1 + IF (NCF > 1) THEN + DO J = 1, NCF - 1 ! print *,'j= ',j,ncf - DO I = NCORP1, NW + DO I = NCORP1, NW ! print *,i ! print *, IQ(I,J), JQS(1,I,J), JQS(2,I,J),JQS(3,I,J) ! print *, IQ(I,ncf), JQS(1,I,ncf), JQS(2,I,ncf),JQS(3,I,ncf) - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 -! WRITE (6, *) I -! WRITE (6, *) JCUP(I,J), JCUP(I,NCF) - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (6, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 +! WRITE (6, *) I +! WRITE (6, *) JCUP(I,J), JCUP(I,NCF) + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (6, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) - WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty' - WRITE (6, *) ' in all CSFs; eliminating this' - WRITE (6, *) ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) - CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) + WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty' + WRITE (6, *) ' in all CSFs; eliminating this' + WRITE (6, *) ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) + CALL PACK (ITEMP, II, IQA(1:NNNW,J)) + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL ! ! All done; report ! - CALL CONVRT (NCF, RECORD, LENTH) -! WRITE (6, *) ' there are '//RECORD(1:LENTH)//' relativistic CSFs;' -! WRITE (6, *) ' ... load complete;' + CALL CONVRT (NCF, RECORD, LENTH) +! WRITE (6, *) ' there are '//RECORD(1:LENTH)//' relativistic CSFs;' +! WRITE (6, *) ' ... load complete;' ! ! Debug printout ! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF -! - RETURN -! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 - READ (21, '(A)', ERR=29, END=29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (6, *) RECORD(1:LENTH) - END DO - 29 CONTINUE - CLOSE(21) - STOP -! - END SUBROUTINE LODCSLM + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF +! + RETURN +! + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 + READ (21, '(A)', ERR=29, END=29) RECORD + LENTH = LEN_TRIM(RECORD) + WRITE (6, *) RECORD(1:LENTH) + END DO + 29 CONTINUE + CLOSE(21) + STOP +! + END SUBROUTINE LODCSLM diff --git a/src/appl/rtransition90_mpi/lodcslm_I.f90 b/src/appl/rtransition90_mpi/lodcslm_I.f90 index c53b9ee3b..6bd4dda19 100644 --- a/src/appl/rtransition90_mpi/lodcslm_I.f90 +++ b/src/appl/rtransition90_mpi/lodcslm_I.f90 @@ -1,10 +1,10 @@ - MODULE lodcslm_I + MODULE lodcslm_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcslm (NCORE) - INTEGER, INTENT(OUT) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodcslm (NCORE) + INTEGER, INTENT(OUT) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/lodrwffmpi.f90 b/src/appl/rtransition90_mpi/lodrwffmpi.f90 index 0fc660231..870118671 100644 --- a/src/appl/rtransition90_mpi/lodrwffmpi.f90 +++ b/src/appl/rtransition90_mpi/lodrwffmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFF(NAME) + SUBROUTINE LODRWFF(NAME) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -8,13 +8,13 @@ SUBROUTINE LODRWFF(NAME) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE memory_man USE def_C @@ -32,10 +32,10 @@ SUBROUTINE LODRWFF(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, K, NWIN, IOS, NPYFF, NAKYFF, MYFF, JJ - REAL(DOUBLE) :: CON, FKK, EYFF, PZY + INTEGER :: J, I, K, NWIN, IOS, NPYFF, NAKYFF, MYFF, JJ + REAL(DOUBLE) :: CON, FKK, EYFF, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER :: G92RWF*6 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the final state @@ -43,97 +43,97 @@ SUBROUTINE LODRWFF(NAME) ! ! Write entry message ! -! WRITE (6, *) 'Loading Radial WaveFunction File for final state...' +! WRITE (6, *) 'Loading Radial WaveFunction File for final state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=69, FILE=NAME(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFFF, NNNP, NWFF, 'PFFF', 'LODRWFF') - CALL ALLOC (QFFF, NNNP, NWFF, 'QFFF', 'LODRWFF') + CALL ALLOC (PFFF, NNNP, NWFF, 'PFFF', 'LODRWFF') + CALL ALLOC (QFFF, NNNP, NWFF, 'QFFF', 'LODRWFF') ! ! Setup: (1) Orbital arrays to zero ! (2) Array E to -1 (no orbitals estimated) ! (3) Parameters GAMMA for each orbital ! - CON = Z/C - CON = CON*CON -! - DO J = 1, NWFF - PFFF(:NNNP,J) = 0.0D00 - QFFF(:NNNP,J) = 0.0D00 -! - EFF(J) = -1.0D00 -! - K = ABS(NAKFF(J)) - IF (NPARM > 0) THEN - GAMAFF(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMAFF(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NPFF(J), NHFF(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF - ENDIF -! - END DO + CON = Z/C + CON = CON*CON +! + DO J = 1, NWFF + PFFF(:NNNP,J) = 0.0D00 + QFFF(:NNNP,J) = 0.0D00 +! + EFF(J) = -1.0D00 +! + K = ABS(NAKFF(J)) + IF (NPARM > 0) THEN + GAMAFF(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMAFF(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NPFF(J), NHFF(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF + ENDIF +! + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (69, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(69) - ENDIF - - 3 CONTINUE - READ (69, IOSTAT=IOS) NPYFF, NAKYFF, EYFF, MYFF - IF (IOS == 0) THEN - CALL ALLOC (PA, MYFF, 'PA', 'LODRWFF' ) - CALL ALLOC (QA, MYFF, 'QA', 'LODRWFF' ) - CALL ALLOC (RA, MYFF, 'RA', 'LODRWFF' ) - READ (69) PZY, (PA(I),I=1,MYFF), (QA(I),I=1,MYFF) - READ (69) (RA(I),I=1,MYFF) - - DO J = 1, NWFF + NWIN = 0 + READ (69, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(69) + ENDIF + + 3 CONTINUE + READ (69, IOSTAT=IOS) NPYFF, NAKYFF, EYFF, MYFF + IF (IOS == 0) THEN + CALL ALLOC (PA, MYFF, 'PA', 'LODRWFF' ) + CALL ALLOC (QA, MYFF, 'QA', 'LODRWFF' ) + CALL ALLOC (RA, MYFF, 'RA', 'LODRWFF' ) + READ (69) PZY, (PA(I),I=1,MYFF), (QA(I),I=1,MYFF) + READ (69) (RA(I),I=1,MYFF) + + DO J = 1, NWFF IF (.NOT.(EFF(J)<0.0D00 .AND. NPYFF==NPFF(J) .AND. NAKYFF==NAKFF(J)& - )) CYCLE - PZFF(J) = PZY - EFF(J) = EYFF - MFFF(J) = MYFF - DO JJ = 1, MFFF(J) - PFFF(JJ,J) = PA(JJ) - QFFF(JJ,J) = QA(JJ) - END DO - NWIN = NWIN + 1 - END DO - CALL DALLOC (PA, 'PA', 'LODRWFF') - CALL DALLOC (QA, 'QA', 'LODRWFF') - CALL DALLOC (RA, 'RA', 'LODRWFF') - GO TO 3 - ENDIF + )) CYCLE + PZFF(J) = PZY + EFF(J) = EYFF + MFFF(J) = MYFF + DO JJ = 1, MFFF(J) + PFFF(JJ,J) = PA(JJ) + QFFF(JJ,J) = QA(JJ) + END DO + NWIN = NWIN + 1 + END DO + CALL DALLOC (PA, 'PA', 'LODRWFF') + CALL DALLOC (QA, 'QA', 'LODRWFF') + CALL DALLOC (RA, 'RA', 'LODRWFF') + GO TO 3 + ENDIF ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWFF) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - STOP - ENDIF + IF (NWIN < NWFF) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + STOP + ENDIF ! -! WRITE (6, *) ' ... load complete;' +! WRITE (6, *) ' ... load complete;' ! - CLOSE(69) - - RETURN - END SUBROUTINE LODRWFF + CLOSE(69) + + RETURN + END SUBROUTINE LODRWFF diff --git a/src/appl/rtransition90_mpi/lodrwffmpi_I.f90 b/src/appl/rtransition90_mpi/lodrwffmpi_I.f90 index 6b8a167ef..95156dccd 100644 --- a/src/appl/rtransition90_mpi/lodrwffmpi_I.f90 +++ b/src/appl/rtransition90_mpi/lodrwffmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE lodrwff_I + MODULE lodrwff_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwff (NAME) - CHARACTER (LEN = 128), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwff (NAME) + CHARACTER (LEN = 128), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/lodrwfimpi.f90 b/src/appl/rtransition90_mpi/lodrwfimpi.f90 index 1490e2380..fe6170e21 100644 --- a/src/appl/rtransition90_mpi/lodrwfimpi.f90 +++ b/src/appl/rtransition90_mpi/lodrwfimpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWFI(NAME) + SUBROUTINE LODRWFI(NAME) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -8,11 +8,11 @@ SUBROUTINE LODRWFI(NAME) ! Written by Per Jonsson June 1996 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP @@ -32,105 +32,105 @@ SUBROUTINE LODRWFI(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, K, NWIN, IOS, NPYII, NAKYII, MYII, JJ - REAL(DOUBLE) :: CON, FKK, EYII, PZY + INTEGER :: J, I, K, NWIN, IOS, NPYII, NAKYII, MYII, JJ + REAL(DOUBLE) :: CON, FKK, EYII, PZY REAL(DOUBLE), DIMENSION(:), pointer :: pa, qa, ra - CHARACTER :: G92RWF*6 + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! Common relevant for the initial state ! ! Write entry message ! -! WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' +! WRITE (6, *) 'Loading Radial WaveFunction File for initial state...' ! ! Open the radial wave function file ! - J = INDEX(NAME,' ') + J = INDEX(NAME,' ') OPEN(UNIT=69, FILE=NAME(1:J-1)//'.bw', FORM='UNFORMATTED', STATUS='OLD', & - POSITION='asis') + POSITION='asis') ! ! Allocate storage to orbital arrays ! - CALL ALLOC (PFII, NNNP, NWII, 'PFII', 'LODRWFI') - CALL ALLOC (QFII, NNNP, NWII, 'QFII', 'LODRWFI') -! - CON = Z/C - CON = CON*CON -! - WRITE (*, *) 'NWII', NWII - DO J = 1, NWII - WRITE (*, *) NAKII(J), NPII(J), NHII(J) - PFII(:NNNP,J) = 0.0D00 - QFII(:NNNP,J) = 0.0D00 -! - EII(J) = -1.0D00 -! - K = ABS(NAKII(J)) - IF (NPARM > 0) THEN - GAMAII(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMAII(J) = SQRT(FKK - CON) - ELSE - WRITE (6, *) 'LODRWF: Imaginary gamma parameter' - WRITE (6, *) ' for ', NPII(J), NHII(J), ' orbital; the' - WRITE (6, *) ' point model for the nucleus' - WRITE (6, *) ' is inappropriate for Z > ', C, '.' - STOP - ENDIF - ENDIF -! - END DO + CALL ALLOC (PFII, NNNP, NWII, 'PFII', 'LODRWFI') + CALL ALLOC (QFII, NNNP, NWII, 'QFII', 'LODRWFI') +! + CON = Z/C + CON = CON*CON +! + WRITE (*, *) 'NWII', NWII + DO J = 1, NWII + WRITE (*, *) NAKII(J), NPII(J), NHII(J) + PFII(:NNNP,J) = 0.0D00 + QFII(:NNNP,J) = 0.0D00 +! + EII(J) = -1.0D00 +! + K = ABS(NAKII(J)) + IF (NPARM > 0) THEN + GAMAII(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMAII(J) = SQRT(FKK - CON) + ELSE + WRITE (6, *) 'LODRWF: Imaginary gamma parameter' + WRITE (6, *) ' for ', NPII(J), NHII(J), ' orbital; the' + WRITE (6, *) ' point model for the nucleus' + WRITE (6, *) ' is inappropriate for Z > ', C, '.' + STOP + ENDIF + ENDIF +! + END DO ! ! Read orbital information from Read Orbitals File; ! - NWIN = 0 - READ (69, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (6, *) 'This is not a Radial WaveFunction File;' - CLOSE(69) - ENDIF - - 3 CONTINUE - READ (69, IOSTAT=IOS) NPYII, NAKYII, EYII, MYII - IF (IOS == 0) THEN - CALL ALLOC (PA, MYII, 'PA', 'LODRWFI') - CALL ALLOC (QA, MYII, 'QA', 'LODRWFI') - CALL ALLOC (RA, MYII, 'RA', 'LODRWFI') - READ (69) PZY, (PA(I),I=1,MYII), (QA(I),I=1,MYII) - READ (69) (RA(I),I=1,MYII) - - DO J = 1, NWII + NWIN = 0 + READ (69, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (6, *) 'This is not a Radial WaveFunction File;' + CLOSE(69) + ENDIF + + 3 CONTINUE + READ (69, IOSTAT=IOS) NPYII, NAKYII, EYII, MYII + IF (IOS == 0) THEN + CALL ALLOC (PA, MYII, 'PA', 'LODRWFI') + CALL ALLOC (QA, MYII, 'QA', 'LODRWFI') + CALL ALLOC (RA, MYII, 'RA', 'LODRWFI') + READ (69) PZY, (PA(I),I=1,MYII), (QA(I),I=1,MYII) + READ (69) (RA(I),I=1,MYII) + + DO J = 1, NWII IF (.NOT.(EII(J)<0.0D00 .AND. NPYII==NPII(J) .AND. NAKYII==NAKII(J)& - )) CYCLE - PZII(J) = PZY - EII(J) = EYII - MFII(J) = MYII - DO JJ = 1, MFII(J) - PFII(JJ,J) = PA(JJ) - QFII(JJ,J) = QA(JJ) - END DO - NWIN = NWIN + 1 - END DO - CALL DALLOC (PA, 'PA', 'LODRWFI') - CALL DALLOC (QA, 'QA', 'LODRWFI') - CALL DALLOC (RA, 'RA', 'LODRWFI') - GO TO 3 - ENDIF + )) CYCLE + PZII(J) = PZY + EII(J) = EYII + MFII(J) = MYII + DO JJ = 1, MFII(J) + PFII(JJ,J) = PA(JJ) + QFII(JJ,J) = QA(JJ) + END DO + NWIN = NWIN + 1 + END DO + CALL DALLOC (PA, 'PA', 'LODRWFI') + CALL DALLOC (QA, 'QA', 'LODRWFI') + CALL DALLOC (RA, 'RA', 'LODRWFI') + GO TO 3 + ENDIF ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NWII) THEN - WRITE (6, *) 'LODRWF: All required orbitals not' - WRITE (6, *) ' found.' - STOP - ENDIF + IF (NWIN < NWII) THEN + WRITE (6, *) 'LODRWF: All required orbitals not' + WRITE (6, *) ' found.' + STOP + ENDIF ! -! WRITE (6, *) ' ... load complete;' +! WRITE (6, *) ' ... load complete;' ! - CLOSE(69) - - RETURN - END SUBROUTINE LODRWFI + CLOSE(69) + + RETURN + END SUBROUTINE LODRWFI diff --git a/src/appl/rtransition90_mpi/lodrwfimpi_I.f90 b/src/appl/rtransition90_mpi/lodrwfimpi_I.f90 index 6cd90dfe9..886604273 100644 --- a/src/appl/rtransition90_mpi/lodrwfimpi_I.f90 +++ b/src/appl/rtransition90_mpi/lodrwfimpi_I.f90 @@ -1,10 +1,10 @@ - MODULE lodrwfi_I + MODULE lodrwfi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:25:11 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwfi (NAME) - CHARACTER (LEN = 128), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodrwfi (NAME) + CHARACTER (LEN = 128), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/mctinmpi.f90 b/src/appl/rtransition90_mpi/mctinmpi.f90 index 723c60a54..cd2b9aed5 100644 --- a/src/appl/rtransition90_mpi/mctinmpi.f90 +++ b/src/appl/rtransition90_mpi/mctinmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCTIN(IOPAR, JKP, NAME) + SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! * ! This routine loads coefficients with parity and rank specified * ! by KP(JKP) into the arrays ISLDR and XSLDR. IOPAR is the parity * @@ -10,80 +10,80 @@ SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! Updated by Jacek Bieron Last revision: 10 Mar 1994 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW USE debug_C USE decide_C USE def_C USE foparm_C - USE OFFD_C + USE OFFD_C USE orb_C - USE OSC_C + USE OSC_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcnsa_I - USE alcnta_I + USE alcnsa_I + USE alcnta_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IOPAR - INTEGER, INTENT(IN) :: JKP - CHARACTER :: NAME(2)*24 + INTEGER :: IOPAR + INTEGER, INTENT(IN) :: JKP + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NFILE2,M,K,IBLKI,IBLKF,I,LABL,NCSF,J,nprocsd,myidd - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL - LOGICAL :: AVAIL + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + LOGICAL :: AVAIL !----------------------------------------------- ! ! Read the data back as required by OSCL conventions ! - NFILE2 = NFILE1 + JKP - - M = 0 - K = 0 + NFILE2 = NFILE1 + JKP + + M = 0 + K = 0 ! READ (NFILE2) IBLKI,IBLKF,NW,NKP,nprocsd,myidd - READ (NFILE2) NINT + READ (NFILE2) NINT ! - DO I = 1, NINT + DO I = 1, NINT ! - READ (NFILE2) LABL, NCSF + READ (NFILE2) LABL, NCSF ! - M = M + 1 + M = M + 1 !bieron IF (M >= NSDIM) CALL ALCNSA (JJA, JJB, HB1, HB2, HC1, & - HC2, HM1, HM2, LAB, NPTR, NSDIM, 2) - LAB(M) = LABL + HC2, HM1, HM2, LAB, NPTR, NSDIM, 2) + LAB(M) = LABL ! ! Read configuration pairs and coefficients for this integral ! - 4 CONTINUE - IF (NCSF + K > NTDIM) THEN - CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 2) - GO TO 4 - ENDIF - NPTR(M) = K - READ (NFILE2) (ISLDR(J + K),ISLDR1(J + K),XSLDR(J + K),J=1,NCSF) + 4 CONTINUE + IF (NCSF + K > NTDIM) THEN + CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 2) + GO TO 4 + ENDIF + NPTR(M) = K + READ (NFILE2) (ISLDR(J + K),ISLDR1(J + K),XSLDR(J + K),J=1,NCSF) ! write(*,*) (ISLDR(J+K),XSLDR(J+K),J = 1,NCSF) - K = K + NCSF + K = K + NCSF ! - END DO + END DO ! ! Close (and hence release) the scratch file ! @@ -92,13 +92,13 @@ SUBROUTINE MCTIN(IOPAR, JKP, NAME) ! CLOSE (unit=NFILE,status="DELETE") ! ENDIF ! - NPTR(M+1) = K - NINTEG = M + NPTR(M+1) = K + NINTEG = M ! - RETURN + RETURN ! 301 FORMAT(/,/,/,1X,I8,' MCT coefficients generated for rank ',I2,& - ' and parity ',I2,/,/) - RETURN + ' and parity ',I2,/,/) + RETURN ! - END SUBROUTINE MCTIN + END SUBROUTINE MCTIN diff --git a/src/appl/rtransition90_mpi/mctinmpi_I.f90 b/src/appl/rtransition90_mpi/mctinmpi_I.f90 index f2d736969..85fb1f878 100644 --- a/src/appl/rtransition90_mpi/mctinmpi_I.f90 +++ b/src/appl/rtransition90_mpi/mctinmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE mctin_I + MODULE mctin_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mctin (IOPAR, JKP, NAME) - INTEGER :: IOPAR + SUBROUTINE mctin (IOPAR, JKP, NAME) + INTEGER :: IOPAR !VAST...Dummy argument IOPAR is not referenced in this routine. - INTEGER, INTENT(IN) :: JKP - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: JKP + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/mctoutmpi_gg.f90 b/src/appl/rtransition90_mpi/mctoutmpi_gg.f90 index 5e86fa082..b9e34ac70 100644 --- a/src/appl/rtransition90_mpi/mctoutmpi_gg.f90 +++ b/src/appl/rtransition90_mpi/mctoutmpi_gg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MCTOUT(IOPAR, JKP, NAME) + SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! * ! This routine loads coefficients with parity and rank specified * ! by KP(JKP) into the arrays ISLDR and XSLDR. IOPAR is the parity * @@ -10,13 +10,13 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! Updated by Jacek Bieron Last revision: 10 Mar 1994 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW USE memory_man USE blk_C @@ -24,35 +24,35 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) USE decide_C USE foparm_C USE orb_C - USE OFFD_C - USE OSC_C + USE OFFD_C + USE OSC_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE angdata_I - USE itjpo_I - USE oneparticlejj_I - USE trsort_I + USE angdata_I + USE itjpo_I + USE oneparticlejj_I + USE trsort_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IOPAR - INTEGER :: JKP - CHARACTER :: NAME(2)*24 + INTEGER :: IOPAR + INTEGER :: JKP + CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NFILE2, IBLKI, IBLKF, NMCT, NLABEL, NCFI0, NCFF0, IC, IR, NCR& - , IA, IB, NEWSIZ, I - LOGICAL :: AVAIL + , IA, IB, NEWSIZ, I + LOGICAL :: AVAIL INTEGER, DIMENSION(:), pointer :: label REAL(DOUBLE), DIMENSION(:), pointer:: coeff REAL(DOUBLE), DIMENSION(NNNW) :: tshell @@ -65,29 +65,29 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! ! Check if angular data is available on file ! - NFILE2 = NFILE1 + JKP - CALL ANGDATA (NAME, AVAIL, JKP, NFILE2) - + NFILE2 = NFILE1 + JKP + CALL ANGDATA (NAME, AVAIL, JKP, NFILE2) + ! ! If angular data is not available open the scratch file to store the ! coefficients; position file ! to beginning ! ! - LK = ABS(KP(JKP)) - IOPAR = ISIGN(1,KP(JKP)) - IF (AVAIL) RETURN -! WRITE (6, *) 'LK,IOPAR,from MCTOUT' -! WRITE (6, *) LK, IOPAR + LK = ABS(KP(JKP)) + IOPAR = ISIGN(1,KP(JKP)) + IF (AVAIL) RETURN +! WRITE (6, *) 'LK,IOPAR,from MCTOUT' +! WRITE (6, *) LK, IOPAR ! ! Start of the block loops - DO IBLKI = 1, NBLOCKI - DO IBLKF = 1, NBLOCKF + DO IBLKI = 1, NBLOCKI + DO IBLKF = 1, NBLOCKF ! OPEN (NFILE,STATUS = 'new', FORM = 'UNFORMATTED') ! Sometimes, when there has been an error, status need to be "unknown" !CFF - OPEN(NFILE,STATUS='unknown',FORM='UNFORMATTED') - NMCT = 0 + OPEN(NFILE,STATUS='unknown',FORM='UNFORMATTED') + NMCT = 0 ! ! ! If angular data is not available @@ -97,103 +97,103 @@ SUBROUTINE MCTOUT(IOPAR, JKP, NAME) ! ! Allocate storage to buffer arrays ! - NLABEL = 32 - CALL ALLOC (LABEL, NLABEL, 'LABEL', 'MCTOUT') - CALL ALLOC (COEFF, NLABEL, 'COEFF', 'MCTOUT') - - IF (IBLKI == 1) THEN - NCFI0 = 1 - ELSE - NCFI0 = NCFI(IBLKI-1) + 1 - ENDIF -! - IF (IBLKF == 1) THEN - NCFF0 = NCFI(NBLOCKI) + 1 - ELSE - NCFF0 = NCFI(NBLOCKI) + NCFF(IBLKF-1) + 1 - ENDIF + NLABEL = 32 + CALL ALLOC (LABEL, NLABEL, 'LABEL', 'MCTOUT') + CALL ALLOC (COEFF, NLABEL, 'COEFF', 'MCTOUT') + + IF (IBLKI == 1) THEN + NCFI0 = 1 + ELSE + NCFI0 = NCFI(IBLKI-1) + 1 + ENDIF +! + IF (IBLKF == 1) THEN + NCFF0 = NCFI(NBLOCKI) + 1 + ELSE + NCFF0 = NCFI(NBLOCKI) + NCFF(IBLKF-1) + 1 + ENDIF DO IC = myid+NCFI0, NCFI(IBLKI), nprocs - DO IR = NCFF0, NCFI(NBLOCKI) + NCFF(IBLKF) + DO IR = NCFF0, NCFI(NBLOCKI) + NCFF(IBLKF) ! ! IR = IC ! - NCR = 0 - + NCR = 0 + ! ! In many case one is interested only in M1 and E2 transitions between ! levels with different J values. If this is the case then the do check ! on the J quantum numbers of the CSFs before calling TNSRJJ. ! - IF (KP(JKP)==1 .AND. NOFFD1==1) THEN - IF (ITJPO(IC) == ITJPO(IR)) CYCLE - ENDIF - IF (KP(JKP)==2 .AND. NOFFD2==1) THEN - IF (ITJPO(IC) == ITJPO(IR)) CYCLE - ENDIF + IF (KP(JKP)==1 .AND. NOFFD1==1) THEN + IF (ITJPO(IC) == ITJPO(IR)) CYCLE + ENDIF + IF (KP(JKP)==2 .AND. NOFFD2==1) THEN + IF (ITJPO(IC) == ITJPO(IR)) CYCLE + ENDIF ! if(ispar(ic)*ispar(ir)*iopar.ne.1. ! & or.itrig(itjpo(ic),itjpo(ir),2*lk+1).ne.1) go to 13 ! if(ichkq1(IC,IR).eq.0) go to 13 CALL ONEPARTICLEJJ(LK,IOPAR,IC,IR,IA,IB,TSHELL) - IF (IA /= 0) THEN - IF (IA == IB) THEN - DO IA = 1, NW - IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE - NCR = NCR + 1 - IF (NCR > NLABEL) THEN - NEWSIZ = 2*NLABEL - CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') - CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') - NLABEL = NEWSIZ - ENDIF - LABEL(NCR) = IA*KEYORB + IA - COEFF(NCR) = TSHELL(IA) - END DO - ELSE - IF (ABS(TSHELL(1)) > CUTOFF) THEN - NCR = NCR + 1 - IF (NCR > NLABEL) THEN - NEWSIZ = 2*NLABEL - CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') - CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') - NLABEL = NEWSIZ - ENDIF - LABEL(NCR) = IA*KEYORB + IB - COEFF(NCR) = TSHELL(1) - ENDIF - ENDIF - ENDIF - IF (NCR <= 0) CYCLE - - WRITE (NFILE) IC - NCFI0 + 1, IR - NCFF0 + 1, NCR - WRITE (NFILE) (LABEL(I),COEFF(I),I=1,NCR) - NMCT = NMCT + NCR - -! - END DO - END DO + IF (IA /= 0) THEN + IF (IA == IB) THEN + DO IA = 1, NW + IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE + NCR = NCR + 1 + IF (NCR > NLABEL) THEN + NEWSIZ = 2*NLABEL + CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') + CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') + NLABEL = NEWSIZ + ENDIF + LABEL(NCR) = IA*KEYORB + IA + COEFF(NCR) = TSHELL(IA) + END DO + ELSE + IF (ABS(TSHELL(1)) > CUTOFF) THEN + NCR = NCR + 1 + IF (NCR > NLABEL) THEN + NEWSIZ = 2*NLABEL + CALL RALLOC (LABEL, NEWSIZ, 'LABEL', 'MCTOUT') + CALL RALLOC (COEFF, NEWSIZ, 'COEFF', 'MCTOUT') + NLABEL = NEWSIZ + ENDIF + LABEL(NCR) = IA*KEYORB + IB + COEFF(NCR) = TSHELL(1) + ENDIF + ENDIF + ENDIF + IF (NCR <= 0) CYCLE + + WRITE (NFILE) IC - NCFI0 + 1, IR - NCFF0 + 1, NCR + WRITE (NFILE) (LABEL(I),COEFF(I),I=1,NCR) + NMCT = NMCT + NCR + +! + END DO + END DO ! ! Deallocate storage for buffer arrays ! - CALL DALLOC (LABEL, 'LABEL', 'MCTOUT') - CALL DALLOC (COEFF, 'COEFF', 'MCTOUT') + CALL DALLOC (LABEL, 'LABEL', 'MCTOUT') + CALL DALLOC (COEFF, 'COEFF', 'MCTOUT') ! -! WRITE (*, 301) NMCT, LK, IOPAR +! WRITE (*, 301) NMCT, LK, IOPAR ! ! Sort the MCT coefficients by integral labels ! - CALL TRSORT (NAME, NFILE, NFILE2, LDBPA(2), JKP, IBLKI, IBLKF) - CLOSE(NFILE, STATUS='delete') + CALL TRSORT (NAME, NFILE, NFILE2, LDBPA(2), JKP, IBLKI, IBLKF) + CLOSE(NFILE, STATUS='delete') ! end of the loops for blocks - END DO - END DO + END DO + END DO ! ! Read the data back as required by OSCL conventions ! - REWIND (NFILE2) - RETURN + REWIND (NFILE2) + RETURN ! 301 FORMAT(/,/,/,1X,I8,' MCT coefficients generated for rank ',I2,& - ' and parity ',I2,/,/) - RETURN + ' and parity ',I2,/,/) + RETURN ! - END SUBROUTINE MCTOUT + END SUBROUTINE MCTOUT diff --git a/src/appl/rtransition90_mpi/mctoutmpi_gg_I.f90 b/src/appl/rtransition90_mpi/mctoutmpi_gg_I.f90 index 0c399bdf5..0fdc42de5 100644 --- a/src/appl/rtransition90_mpi/mctoutmpi_gg_I.f90 +++ b/src/appl/rtransition90_mpi/mctoutmpi_gg_I.f90 @@ -1,12 +1,12 @@ - MODULE mctout_I + MODULE mctout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:29:28 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mctout (IOPAR, JKP, NAME) - INTEGER, INTENT(OUT) :: IOPAR - INTEGER, INTENT(IN) :: JKP - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mctout (IOPAR, JKP, NAME) + INTEGER, INTENT(OUT) :: IOPAR + INTEGER, INTENT(IN) :: JKP + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/merg12mpi.f90 b/src/appl/rtransition90_mpi/merg12mpi.f90 index 9c04db936..da444554b 100644 --- a/src/appl/rtransition90_mpi/merg12mpi.f90 +++ b/src/appl/rtransition90_mpi/merg12mpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE MERG12(NAME, NCORER, NCORE) + SUBROUTINE MERG12(NAME, NCORER, NCORE) ! * ! This subroutines merges the initial and final state lists * ! Observ that there may doublets in this list if the initial * @@ -9,13 +9,13 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE def_C USE orb_C @@ -23,170 +23,170 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE iqr_I - USE ispar_I - USE isparr_I - USE itjpo_I - USE itjpor_I + USE iq_I + USE iqr_I + USE ispar_I + USE isparr_I + USE itjpo_I + USE itjpor_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NCORER - INTEGER , INTENT(IN) :: NCORE + INTEGER , INTENT(IN) :: NCORER + INTEGER , INTENT(IN) :: NCORE CHARACTER , INTENT(IN) :: NAME(2)*128 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1 - INTEGER, DIMENSION(0:NNNW + 1) :: NEWNP - INTEGER, DIMENSION(NNNW) :: NEWNAK, ICON, ICON1 - INTEGER :: I, J, ICOMP, NEW, IPI1, IPI2, K, NEW1, NEW2, M, NLINE - CHARACTER :: LINE*500 - CHARACTER, DIMENSION(NNNW) :: NEWNH*2 - CHARACTER :: NEW3*2 + INTEGER :: J1 + INTEGER, DIMENSION(0:NNNW + 1) :: NEWNP + INTEGER, DIMENSION(NNNW) :: NEWNAK, ICON, ICON1 + INTEGER :: I, J, ICOMP, NEW, IPI1, IPI2, K, NEW1, NEW2, M, NLINE + CHARACTER :: LINE*500 + CHARACTER, DIMENSION(NNNW) :: NEWNH*2 + CHARACTER :: NEW3*2 !----------------------------------------------- ! ! ! NCFI(I): the end position of the Ith block for the initial states in the globle CSF list ! NCFF(I): the end position of the Ith block for the final states in the globle CSF list - + ! OPEN(UNIT=21, FILE='SLASK', FORM='FORMATTED', STATUS='UNKNOWN', POSITION=& - 'asis') + 'asis') ! ! The same number of electrons must appear in both lists ! - IF (NELECR /= NELEC) THEN - WRITE (6, *) 'The number of electrons is not equal in the' - WRITE (6, *) ' first and second GRASP92 Configuration' - WRITE (6, *) ' symmetry list files.' - STOP - ENDIF + IF (NELECR /= NELEC) THEN + WRITE (6, *) 'The number of electrons is not equal in the' + WRITE (6, *) ' first and second GRASP92 Configuration' + WRITE (6, *) ' symmetry list files.' + STOP + ENDIF ! ! THe core orbitals must be the same ! - IF (NCORE /= NCORER) THEN - WRITE (6, *) 'The number of core orbitals must be the same' - STOP - ENDIF - - DO I = 1, NCORE - IF (NP(I)==NPR(I) .AND. NAK(I)==NAKR(I)) CYCLE - WRITE (6, *) 'The core orbitals must be the same' - STOP - END DO - - ICON(:NW) = 0 + IF (NCORE /= NCORER) THEN + WRITE (6, *) 'The number of core orbitals must be the same' + STOP + ENDIF + + DO I = 1, NCORE + IF (NP(I)==NPR(I) .AND. NAK(I)==NAKR(I)) CYCLE + WRITE (6, *) 'The core orbitals must be the same' + STOP + END DO + + ICON(:NW) = 0 ! ! For each orbital in the initial list check if there is a corresponding ! orbital in the final list. If so give the number of the corresponding ! orbital ! - DO I = 1, NW - DO J = 1, NWR - IF (NP(I)/=NPR(J) .OR. NAK(I)/=NAKR(J)) CYCLE - ICON(I) = J - END DO - END DO + DO I = 1, NW + DO J = 1, NWR + IF (NP(I)/=NPR(J) .OR. NAK(I)/=NAKR(J)) CYCLE + ICON(I) = J + END DO + END DO ! ! Check if the ordering of the initial and final state orbitals ! is consistent. The condition for this is that ICON is increasing ! - J = 0 - DO I = 1, NW - IF (ICON(I) == 0) CYCLE - J = J + 1 - ICON1(J) = ICON(I) - END DO - - ICOMP = ICON1(1) - DO I = 2, J - IF (ICON1(I) < ICOMP) THEN - WRITE (*, *) ' In merg12: ordering of the initial and final' - WRITE (*, *) ' state orbitals is inconsistent. STOP' - STOP - ELSE - ICOMP = ICON1(I) - ENDIF - END DO + J = 0 + DO I = 1, NW + IF (ICON(I) == 0) CYCLE + J = J + 1 + ICON1(J) = ICON(I) + END DO + + ICOMP = ICON1(1) + DO I = 2, J + IF (ICON1(I) < ICOMP) THEN + WRITE (*, *) ' In merg12: ordering of the initial and final' + WRITE (*, *) ' state orbitals is inconsistent. STOP' + STOP + ELSE + ICOMP = ICON1(I) + ENDIF + END DO ! ! Determine a common orbital set for the initial and final state. ! The common set must be such that the order of both the initial and ! final state sets are preserved. ! - DO I = 1, NWR - NEWNP(I) = NPR(I) - NEWNAK(I) = NAKR(I) - NEWNH(I) = NHR(I) - WRITE (*, *) NEWNP(I), NEWNH(I) - END DO + DO I = 1, NWR + NEWNP(I) = NPR(I) + NEWNAK(I) = NAKR(I) + NEWNH(I) = NHR(I) + WRITE (*, *) NEWNP(I), NEWNH(I) + END DO ! ! Add the initial state orbitals at the end ! - NEW = NWR - DO I = 1, NW - IF (ICON(I) /= 0) CYCLE - NEW = NEW + 1 - NEWNP(NEW) = NP(I) - NEWNAK(NEW) = NAK(I) - NEWNH(NEW) = NH(I) - WRITE (*, *) NEWNP(NEW), NEWNH(NEW), NEW - END DO + NEW = NWR + DO I = 1, NW + IF (ICON(I) /= 0) CYCLE + NEW = NEW + 1 + NEWNP(NEW) = NP(I) + NEWNAK(NEW) = NAK(I) + NEWNH(NEW) = NH(I) + WRITE (*, *) NEWNP(NEW), NEWNH(NEW), NEW + END DO ! ! Now sort in the orbitals at the end in the right position ! - L193: DO I = NWR + 1, NEW + L193: DO I = NWR + 1, NEW ! ! Position in initial state list ! - DO J = 1, NW - IF (NEWNP(I)/=NP(J) .OR. NEWNAK(I)/=NAK(J)) CYCLE - IPI1 = J - END DO - WRITE (*, *) 'i,ipi1', I, IPI1 - - DO J = 1, NWR - IPI2 = 0 - DO K = 1, NW - IF (NEWNP(J)/=NP(K) .OR. NEWNAK(J)/=NAK(K)) CYCLE - IPI2 = K - END DO - WRITE (*, *) 'j,ipi2', J, IPI2 - IF (IPI2 == 0) CYCLE - IF (IPI1 >= IPI2) CYCLE - NEW1 = NEWNP(I) - NEW2 = NEWNAK(I) - NEW3 = NEWNH(I) - NEWNP(I:1+J:(-1)) = NEWNP(I-1:J:(-1)) - NEWNAK(I:1+J:(-1)) = NEWNAK(I-1:J:(-1)) - NEWNH(I:1+J:(-1)) = NEWNH(I-1:J:(-1)) - NEWNP(J) = NEW1 - NEWNAK(J) = NEW2 - NEWNH(J) = NEW3 - DO M = 1, NEW - WRITE (*, *) NEWNP(M), NEWNH(M) - END DO - CYCLE L193 - END DO - END DO L193 - - NW = NEW - NP(:NW) = NEWNP(1:NW) - NAK(:NW) = NEWNAK(:NW) - NH(:NW) = NEWNH(:NW) + DO J = 1, NW + IF (NEWNP(I)/=NP(J) .OR. NEWNAK(I)/=NAK(J)) CYCLE + IPI1 = J + END DO + WRITE (*, *) 'i,ipi1', I, IPI1 + + DO J = 1, NWR + IPI2 = 0 + DO K = 1, NW + IF (NEWNP(J)/=NP(K) .OR. NEWNAK(J)/=NAK(K)) CYCLE + IPI2 = K + END DO + WRITE (*, *) 'j,ipi2', J, IPI2 + IF (IPI2 == 0) CYCLE + IF (IPI1 >= IPI2) CYCLE + NEW1 = NEWNP(I) + NEW2 = NEWNAK(I) + NEW3 = NEWNH(I) + NEWNP(I:1+J:(-1)) = NEWNP(I-1:J:(-1)) + NEWNAK(I:1+J:(-1)) = NEWNAK(I-1:J:(-1)) + NEWNH(I:1+J:(-1)) = NEWNH(I-1:J:(-1)) + NEWNP(J) = NEW1 + NEWNAK(J) = NEW2 + NEWNH(J) = NEW3 + DO M = 1, NEW + WRITE (*, *) NEWNP(M), NEWNH(M) + END DO + CYCLE L193 + END DO + END DO L193 + + NW = NEW + NP(:NW) = NEWNP(1:NW) + NAK(:NW) = NEWNAK(:NW) + NH(:NW) = NEWNH(:NW) ! ! Determine NKL and NKJ ! - DO I = 1, NW - NKJ(I) = 2*ABS(NAK(I)) - 1 - IF (NAK(I) > 0) THEN - NKL(I) = (NKJ(I)+1)/2 - ELSE - NKL(I) = (NKJ(I)-1)/2 - ENDIF - END DO + DO I = 1, NW + NKJ(I) = 2*ABS(NAK(I)) - 1 + IF (NAK(I) > 0) THEN + NKL(I) = (NKJ(I)+1)/2 + ELSE + NKL(I) = (NKJ(I)-1)/2 + ENDIF + END DO ! ! Determine the common core subshells; write out the list; ! determine the pell subshells; write out the list; these @@ -194,87 +194,87 @@ SUBROUTINE MERG12(NAME, NCORER, NCORE) ! one additional line forms the remainder of the header of ! the .csl file ! - WRITE (21, '(A)') 'Core subshells:' - WRITE (21, 301) (NP(I),NH(I),I=1,NCORE) - WRITE (21, '(A)') 'Peel subshells:' - WRITE (21, 301) (NP(I),NH(I),I=NCORE + 1,NW) - WRITE (21, '(A)') 'CSF(s):' + WRITE (21, '(A)') 'Core subshells:' + WRITE (21, 301) (NP(I),NH(I),I=1,NCORE) + WRITE (21, '(A)') 'Peel subshells:' + WRITE (21, 301) (NP(I),NH(I),I=NCORE + 1,NW) + WRITE (21, '(A)') 'CSF(s):' ! ! Now write out all CSFs in the initial and final state list ! - J = INDEX(NAME(1),' ') + J = INDEX(NAME(1),' ') OPEN(UNIT=23, FILE=NAME(1)(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') - - DO I = 1, 5 - READ (23, '(A)') LINE - END DO - - NBLOCKI = 0 - NLINE = 0 - 5 CONTINUE - READ (23, '(A)', END=98) LINE - IF (LINE(1:2) == ' *') THEN - NBLOCKI = NBLOCKI + 1 - NCFI(NBLOCKI) = NLINE/3 - ELSE - NLINE = NLINE + 1 - ENDIF - K = 500 - 10 CONTINUE - IF (LINE(K:K) == ' ') THEN - K = K - 1 - IF (K > 1) GO TO 10 - ENDIF - WRITE (21, '(A)') LINE(1:K) - GO TO 5 - 98 CONTINUE - NBLOCKI = NBLOCKI + 1 - NCFI(NBLOCKI) = NLINE/3 - CLOSE(23) - + POSITION='asis') + + DO I = 1, 5 + READ (23, '(A)') LINE + END DO + + NBLOCKI = 0 + NLINE = 0 + 5 CONTINUE + READ (23, '(A)', END=98) LINE + IF (LINE(1:2) == ' *') THEN + NBLOCKI = NBLOCKI + 1 + NCFI(NBLOCKI) = NLINE/3 + ELSE + NLINE = NLINE + 1 + ENDIF + K = 500 + 10 CONTINUE + IF (LINE(K:K) == ' ') THEN + K = K - 1 + IF (K > 1) GO TO 10 + ENDIF + WRITE (21, '(A)') LINE(1:K) + GO TO 5 + 98 CONTINUE + NBLOCKI = NBLOCKI + 1 + NCFI(NBLOCKI) = NLINE/3 + CLOSE(23) + ! zou ! if(NAME(2).EQ.NAME(1)) return ! zou - J = INDEX(NAME(2),' ') + J = INDEX(NAME(2),' ') OPEN(UNIT=23, FILE=NAME(2)(1:J-1)//'.c', FORM='FORMATTED', STATUS='OLD', & - POSITION='asis') - - DO I = 1, 5 - READ (23, '(A)') LINE - END DO - - NBLOCKF = 0 - NLINE = 0 - 15 CONTINUE - READ (23, '(A)', END=99) LINE - IF (LINE(1:2) == ' *') THEN - NBLOCKF = NBLOCKF + 1 - NCFF(NBLOCKF) = NLINE/3 - ELSE - NLINE = NLINE + 1 - ENDIF - K = 500 - 20 CONTINUE - IF (LINE(K:K) == ' ') THEN - K = K - 1 - IF (K > 1) GO TO 20 - ENDIF - WRITE (21, '(A)') LINE(1:K) - GO TO 15 - 99 CONTINUE - NBLOCKF = NBLOCKF + 1 - NCFF(NBLOCKF) = NLINE/3 - CLOSE(23) - - CLOSE(21) + POSITION='asis') + + DO I = 1, 5 + READ (23, '(A)') LINE + END DO + + NBLOCKF = 0 + NLINE = 0 + 15 CONTINUE + READ (23, '(A)', END=99) LINE + IF (LINE(1:2) == ' *') THEN + NBLOCKF = NBLOCKF + 1 + NCFF(NBLOCKF) = NLINE/3 + ELSE + NLINE = NLINE + 1 + ENDIF + K = 500 + 20 CONTINUE + IF (LINE(K:K) == ' ') THEN + K = K - 1 + IF (K > 1) GO TO 20 + ENDIF + WRITE (21, '(A)') LINE(1:K) + GO TO 15 + 99 CONTINUE + NBLOCKF = NBLOCKF + 1 + NCFF(NBLOCKF) = NLINE/3 + CLOSE(23) + + CLOSE(21) ! - - WRITE (6, *) NBLOCKI - WRITE (6, *) (NCFI(I),I=1,NBLOCKI) - WRITE (6, *) NBLOCKF - WRITE (6, *) (NCFF(I),I=1,NBLOCKF) - 301 FORMAT(120(1X,1I2,1A2)) + + WRITE (6, *) NBLOCKI + WRITE (6, *) (NCFI(I),I=1,NBLOCKI) + WRITE (6, *) NBLOCKF + WRITE (6, *) (NCFF(I),I=1,NBLOCKF) + 301 FORMAT(120(1X,1I2,1A2)) ! - RETURN - END SUBROUTINE MERG12 + RETURN + END SUBROUTINE MERG12 diff --git a/src/appl/rtransition90_mpi/merg12mpi_I.f90 b/src/appl/rtransition90_mpi/merg12mpi_I.f90 index d51fc0055..49be7097d 100644 --- a/src/appl/rtransition90_mpi/merg12mpi_I.f90 +++ b/src/appl/rtransition90_mpi/merg12mpi_I.f90 @@ -1,12 +1,12 @@ - MODULE merg12_I + MODULE merg12_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE merg12 (NAME, NCORER, NCORE) - CHARACTER (LEN = 128), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCORER - INTEGER, INTENT(IN) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE merg12 (NAME, NCORER, NCORE) + CHARACTER (LEN = 128), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCORER + INTEGER, INTENT(IN) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/mrgcslmpi.f90 b/src/appl/rtransition90_mpi/mrgcslmpi.f90 index 9bdb2d7ec..a1a7b0fae 100644 --- a/src/appl/rtransition90_mpi/mrgcslmpi.f90 +++ b/src/appl/rtransition90_mpi/mrgcslmpi.f90 @@ -1,25 +1,25 @@ !*********************************************************************** ! * - SUBROUTINE MRGCSL(NAME) + SUBROUTINE MRGCSL(NAME) ! * ! Entry routine for merging two csl lists * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE def_C, ONLY: EMN, IONCTY, NELEC, Z !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ldcsl1_I - USE ldcsl2_I - USE merg12_I + USE ldcsl1_I + USE ldcsl2_I + USE merg12_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -28,25 +28,25 @@ SUBROUTINE MRGCSL(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCORER, NCORE + INTEGER :: NCORER, NCORE !----------------------------------------------- ! - -! WRITE (6, *) -! WRITE (6, *) 'MRGCSL: Execution begins ...' + +! WRITE (6, *) +! WRITE (6, *) 'MRGCSL: Execution begins ...' ! ! Load the first .csl file ! - CALL LDCSL1 (NCORER, NAME(1)) + CALL LDCSL1 (NCORER, NAME(1)) ! ! Load the second .csl file ! - CALL LDCSL2 (NCORE, NAME(2)) + CALL LDCSL2 (NCORE, NAME(2)) ! ! Merge the two .csl lists, observe that there may be doublets ! among the CSF's ! - CALL MERG12 (NAME, NCORER, NCORE) - - RETURN - END SUBROUTINE MRGCSL + CALL MERG12 (NAME, NCORER, NCORE) + + RETURN + END SUBROUTINE MRGCSL diff --git a/src/appl/rtransition90_mpi/mrgcslmpi_I.f90 b/src/appl/rtransition90_mpi/mrgcslmpi_I.f90 index b91563940..742656489 100644 --- a/src/appl/rtransition90_mpi/mrgcslmpi_I.f90 +++ b/src/appl/rtransition90_mpi/mrgcslmpi_I.f90 @@ -1,10 +1,10 @@ - MODULE mrgcsl_I + MODULE mrgcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mrgcsl (NAME) - CHARACTER (LEN = 128), DIMENSION(2) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE mrgcsl (NAME) + CHARACTER (LEN = 128), DIMENSION(2) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/osclmpi.f90 b/src/appl/rtransition90_mpi/osclmpi.f90 index 7b6b5e993..ac5eab5f2 100644 --- a/src/appl/rtransition90_mpi/osclmpi.f90 +++ b/src/appl/rtransition90_mpi/osclmpi.f90 @@ -1,46 +1,46 @@ !*********************************************************************** ! * - SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) + SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) ! This routine controls the main sequence of routine calls for the * ! calculation of data for transitions between multiconfiguration * ! Dirac-Fock energy levels. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE blk_C USE biorb_C USE def_C, CCMPS=>CCMS USE default_C - USE EIGV_C + USE EIGV_C USE orb_C - USE OSC_C - USE PRNT_C - USE SYMA_C - USE TITL_C - USE WAVE_C + USE OSC_C + USE PRNT_C + USE SYMA_C + USE TITL_C + USE WAVE_C USE jj2lsjbio_C USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cpmix_I - USE alcnsa_I - USE alcnta_I - USE connect_I - USE mctout_I - USE readmix_I - USE mctin_I - USE itrig_I - USE bessj_I - USE csfm_I - USE printa_I + USE cpmix_I + USE alcnsa_I + USE alcnta_I + USE connect_I + USE mctout_I + USE readmix_I + USE mctin_I + USE itrig_I + USE bessj_I + USE csfm_I + USE printa_I USE printals_I IMPLICIT NONE !----------------------------------------------- @@ -53,26 +53,26 @@ SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER*4, PARAMETER :: IAU = 'Hart' - CHARACTER*4, PARAMETER :: IEV = ' eV ' - CHARACTER*4, PARAMETER :: ICM = 'Kays' - CHARACTER*4, PARAMETER :: IHZ = ' Hz ' - CHARACTER*4, PARAMETER :: IANG = ' A ' - INTEGER, PARAMETER :: NCA = 65536 - INTEGER, PARAMETER :: NFILE = 93 - INTEGER, PARAMETER :: NFILE1 = 237 + CHARACTER*4, PARAMETER :: IAU = 'Hart' + CHARACTER*4, PARAMETER :: IEV = ' eV ' + CHARACTER*4, PARAMETER :: ICM = 'Kays' + CHARACTER*4, PARAMETER :: IHZ = ' Hz ' + CHARACTER*4, PARAMETER :: IANG = ' A ' + INTEGER, PARAMETER :: NCA = 65536 + INTEGER, PARAMETER :: NFILE = 93 + INTEGER, PARAMETER :: NFILE1 = 237 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KKA, JKP, NFILE2, IOS, my_NELEC, NCFTOTI, NWI, & NVECSIZI, IOPAR, IBLKI, NCFTOTF, NWF,& NVECSIZF, IBLKF, NVECPR, I, M, & - IELEC, LEVII, LEVFF, ITKPO, ITEST, NLP, LINES, & + IELEC, LEVII, LEVFF, ITKPO, ITEST, NLP, LINES, & ILBL, INUM_II, INUM_FF, ICOUNT1, ICOUNT2, iii REAL(DOUBLE) :: FACTOR, OMEGA, ARGU, ASFA, ASFB, ASFAtmp, ASFBtmp REAL(DOUBLE), DIMENSION(:), pointer :: et, et1, ipr, ipr1, next - LOGICAL :: AVAIL, LSAME - CHARACTER :: ANSW*1, IUNITS*4, G92MIX*6 + LOGICAL :: AVAIL, LSAME + CHARACTER :: ANSW*1, IUNITS*4, G92MIX*6 !----------------------------------------------- ! ! NCFI(I): the end position of the Ith block for the initial states in the globle CSF list @@ -80,8 +80,8 @@ SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) ! ! for the case that the inital file and final file are same ! - LSAME = TRIM(FULLNAME(1)) == TRIM(FULLNAME(2)) - IF (LSAME.and.myid.eq.0) CALL CPMIX (FULLNAME, INPCI) + LSAME = TRIM(FULLNAME(1)) == TRIM(FULLNAME(2)) + IF (LSAME.and.myid.eq.0) CALL CPMIX (FULLNAME, INPCI) call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! ! write header for the result file @@ -99,54 +99,54 @@ SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) end if ! myid .EQ. 0 ! CALL ALCNSA (JJA, JJB, HB1, HB2, HC1, HC2, HM1, & - HM2, LAB, NPTR, NSDIM, 1) - CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 1) + HM2, LAB, NPTR, NSDIM, 1) + CALL ALCNTA (ISLDR, ISLDR1, XSLDR, NTDIM, 1) ! ! Make a connection between the orbitals of the ! merged list and the initial and final state lists ! - CALL CONNECT + CALL CONNECT ! ! Set up units for printing transition energy ! - IF (LTC(1)) THEN + IF (LTC(1)) THEN ! ! Print transition energies in Angstroms ! - FACTOR = AUCM - FACTOR = 1.0D08/FACTOR - IUNITS = IANG + FACTOR = AUCM + FACTOR = 1.0D08/FACTOR + IUNITS = IANG ! - ELSE IF (LTC(2)) THEN + ELSE IF (LTC(2)) THEN ! ! Print energies in eV ! - FACTOR = AUEV - IUNITS = IEV + FACTOR = AUEV + IUNITS = IEV ! - ELSE IF (LTC(3)) THEN + ELSE IF (LTC(3)) THEN ! ! Print transition energies in Hartree Atomic Units ! - FACTOR = 1.0D00 - IUNITS = IAU + FACTOR = 1.0D00 + IUNITS = IAU ! - ELSE IF (LTC(4)) THEN + ELSE IF (LTC(4)) THEN ! ! Print transition energies in Hz ! - FACTOR = AUCM - FACTOR = FACTOR*CCMPS - IUNITS = IHZ + FACTOR = AUCM + FACTOR = FACTOR*CCMPS + IUNITS = IHZ ! - ELSE IF (LTC(5)) THEN + ELSE IF (LTC(5)) THEN ! ! Print transition energies in Kaysers ! - FACTOR = AUCM - IUNITS = ICM + FACTOR = AUCM + IUNITS = ICM ! - ENDIF + ENDIF ! ! Select type of transition ! @@ -157,62 +157,62 @@ SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) ! = (-1)**(N+1) Magnetic N-pole. ! N > 0 ! - KKA = 1 - DO JKP = 1, NKP - NFILE2 = NFILE1 + JKP + KKA = 1 + DO JKP = 1, NKP + NFILE2 = NFILE1 + JKP ! ! read the head of the file of mixing coef. for initial ! - IF (LSAME) FULLNAME(1) = TRIM(FULLNAME(2))//'_CP' - IF (INPCI == 0) THEN + IF (LSAME) FULLNAME(1) = TRIM(FULLNAME(2))//'_CP' + IF (INPCI == 0) THEN OPEN(UNIT=68,FILE=TRIM(FULLNAME(1))//'.cbm', & - FORM='UNFORMATTED',STATUS='OLD') - ELSE + FORM='UNFORMATTED',STATUS='OLD') + ELSE OPEN(UNIT=68, FILE=TRIM(FULLNAME(1))//'.bm', & - FORM='UNFORMATTED',STATUS='OLD') - ENDIF - IF (LSAME) FULLNAME(1) = FULLNAME(2) - READ (68, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - READ (68) NELEC, NCFTOTI, NWI, NVECTOTI, NVECSIZI, NBLOCKI - WRITE (*, *) ' nelec = ', my_NELEC - WRITE (*, *) ' ncftoti = ', NCFTOTI - WRITE (*, *) ' nwi = ', NWI - WRITE (*, *) ' nblocki = ', NBLOCKI - WRITE (*, *) + FORM='UNFORMATTED',STATUS='OLD') + ENDIF + IF (LSAME) FULLNAME(1) = FULLNAME(2) + READ (68, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + READ (68) NELEC, NCFTOTI, NWI, NVECTOTI, NVECSIZI, NBLOCKI + WRITE (*, *) ' nelec = ', my_NELEC + WRITE (*, *) ' ncftoti = ', NCFTOTI + WRITE (*, *) ' nwi = ', NWI + WRITE (*, *) ' nblocki = ', NBLOCKI + WRITE (*, *) ! lbl ICOUNT1 = 0 - CALL LDLBL1 (FULLNAME(1)) + CALL LDLBL1 (FULLNAME(1)) ! If not available generate angular coefficients for all pares of blocks - CALL MCTOUT (IOPAR, JKP, NAME) - DO IBLKI = 1, NBLOCKI - CALL READMIX (NAME, INPCI, 1) + CALL MCTOUT (IOPAR, JKP, NAME) + DO IBLKI = 1, NBLOCKI + CALL READMIX (NAME, INPCI, 1) ! lbl ICOUNT1 = NVECII + ICOUNT1 ! ! read the head of the file of mixing coef. for final ! - IF (INPCI == 0) THEN + IF (INPCI == 0) THEN OPEN(UNIT=78,FILE=TRIM(FULLNAME(2))//'.cbm', & - FORM='UNFORMATTED',STATUS='OLD') - ELSE + FORM='UNFORMATTED',STATUS='OLD') + ELSE OPEN(UNIT=78, FILE=TRIM(FULLNAME(2))//'.bm', & - FORM='UNFORMATTED',STATUS='OLD') - ENDIF - READ (78, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (*, *) 'Not a GRASP mixing file' - STOP - ENDIF - READ (78) NELEC, NCFTOTF, NWF, NVECTOTF, NVECSIZF, NBLOCKF - WRITE (*, *) ' nelec = ', my_NELEC - WRITE (*, *) ' ncftotf = ', NCFTOTF - WRITE (*, *) ' nwf = ', NWF - WRITE (*, *) ' nblockf = ', NBLOCKF - WRITE (*, *) + FORM='UNFORMATTED',STATUS='OLD') + ENDIF + READ (78, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (*, *) 'Not a GRASP mixing file' + STOP + ENDIF + READ (78) NELEC, NCFTOTF, NWF, NVECTOTF, NVECSIZF, NBLOCKF + WRITE (*, *) ' nelec = ', my_NELEC + WRITE (*, *) ' ncftotf = ', NCFTOTF + WRITE (*, *) ' nwf = ', NWF + WRITE (*, *) ' nblockf = ', NBLOCKF + WRITE (*, *) !GG lbl IF(IBLKI .EQ. 1) THEN CALL LDLBL2 (FULLNAME(2)) @@ -237,207 +237,207 @@ SUBROUTINE OSCL(NAME,FULLNAME,tmpdir,startdir,idstring) END IF END IF ICOUNT2 = 0 -!GG lbl end - DO IBLKF = 1, NBLOCKF - CALL READMIX (NAME, INPCI, 2) +!GG lbl end + DO IBLKF = 1, NBLOCKF + CALL READMIX (NAME, INPCI, 2) ! lbl ICOUNT2 = NVECFF + ICOUNT2 ! ! Allocate storage ! - CALL ALLOC (TOTB, NVECFF, 'TOTB', 'OSCL') - CALL ALLOC (TOTC, NVECFF, 'TOTC', 'OSCL') + CALL ALLOC (TOTB, NVECFF, 'TOTB', 'OSCL') + CALL ALLOC (TOTC, NVECFF, 'TOTC', 'OSCL') ! - NVECPR = NVECII*NVECFF - CALL ALLOC (ET, NVECPR, 'ET', 'OSCL' ) - CALL ALLOC (ET1, NVECPR, 'ET1','OSCL' ) - CALL ALLOC (IPR, NVECPR, 'IPR', 'OSCL' ) - CALL ALLOC (IPR1, NVECPR,'IPR1', 'OSCL' ) - CALL ALLOC (NEXT, NVECPR, 'NEXT', 'OSCL') + NVECPR = NVECII*NVECFF + CALL ALLOC (ET, NVECPR, 'ET', 'OSCL' ) + CALL ALLOC (ET1, NVECPR, 'ET1','OSCL' ) + CALL ALLOC (IPR, NVECPR, 'IPR', 'OSCL' ) + CALL ALLOC (IPR1, NVECPR,'IPR1', 'OSCL' ) + CALL ALLOC (NEXT, NVECPR, 'NEXT', 'OSCL') ! ! Initialization for total decay rate ! - TOTC(:NVECFF) = 0.0D00 - TOTB(:NVECFF) = 0.0D00 + TOTC(:NVECFF) = 0.0D00 + TOTB(:NVECFF) = 0.0D00 ! - CALL MCTIN (IOPAR, JKP, NAME) + CALL MCTIN (IOPAR, JKP, NAME) ! - IF (LK > 0) THEN - IELEC = (-1)**LK - IF (IELEC == IOPAR) THEN - KK = 0 - KKA = 0 - ELSE - KK = 1 - IELEC = -IELEC - ENDIF + IF (LK > 0) THEN + IELEC = (-1)**LK + IF (IELEC == IOPAR) THEN + KK = 0 + KKA = 0 + ELSE + KK = 1 + IELEC = -IELEC + ENDIF ! ! Set up list of levels for calculation of oscillator strengths ! sort list into increasing order of energy if option 6 set ! - IF (myid.EQ.0.AND.IBLKI==1.AND.IBLKF==1) THEN - IF (KK == 0) THEN - WRITE (24, 308) LK - ELSE - WRITE (24, 309) LK - ENDIF - WRITE (24, 310) - IF (LTC(1)) THEN - WRITE (24, 311) - IF (.NOT.LTC(7)) THEN - WRITE (24, 312) - ELSE - WRITE (24, 313) - ENDIF - ELSE - WRITE (24, 314) - IF (.NOT.LTC(7)) THEN - WRITE (24, 315) IUNITS - ELSE - WRITE (24, 316) IUNITS - ENDIF - ENDIF + IF (myid.EQ.0.AND.IBLKI==1.AND.IBLKF==1) THEN + IF (KK == 0) THEN + WRITE (24, 308) LK + ELSE + WRITE (24, 309) LK + ENDIF + WRITE (24, 310) + IF (LTC(1)) THEN + WRITE (24, 311) + IF (.NOT.LTC(7)) THEN + WRITE (24, 312) + ELSE + WRITE (24, 313) + ENDIF + ELSE + WRITE (24, 314) + IF (.NOT.LTC(7)) THEN + WRITE (24, 315) IUNITS + ELSE + WRITE (24, 316) IUNITS + ENDIF + ENDIF ENDIF !myid=0 ! - DO LEVII = 1, NVECII + DO LEVII = 1, NVECII ! lbl INUM_II = ICOUNT1 - NVECII + LEVII - DO LEVFF = 1, NVECFF + DO LEVFF = 1, NVECFF ! lbl INUM_FF = ICOUNT2 - NVECFF + LEVFF ! ! Check for consistent parity and J ! - ITKPO = LK + LK + 1 + ITKPO = LK + LK + 1 IF (ITRIG(IATJPOII(LEVII),IATJPOFF(LEVFF),ITKPO) == 0) & - CYCLE - ITEST = IASPARII(LEVII)*IASPARFF(LEVFF)*IELEC - IF (ITEST < 0) CYCLE + CYCLE + ITEST = IASPARII(LEVII)*IASPARFF(LEVFF)*IELEC + IF (ITEST < 0) CYCLE ! ! Calculate and print transition probability data ! - NLP = 70 - 8 - LINES = NLP + NLP = 70 - 8 + LINES = NLP ! - IF (LINES >= NLP) LINES = 0 + IF (LINES >= NLP) LINES = 0 ! - M = LEVFF + NVECFF*(LEVII - 1) + M = LEVFF + NVECFF*(LEVII - 1) ! M = LEVFF+NVECII*(LEVII-1) - ET(M) = EVALFF(LEVFF) + EAVFF - EVALII(LEVII) - EAVII - IF (LSAME .AND. ET(M)<=0.0) CYCLE - OMEGA = -ET(M) - ARGU = OMEGA/C - CALL BESSJ (ARGU) + ET(M) = EVALFF(LEVFF) + EAVFF - EVALII(LEVII) - EAVII + IF (LSAME .AND. ET(M)<=0.0) CYCLE + OMEGA = -ET(M) + ARGU = OMEGA/C + CALL BESSJ (ARGU) ! ! Calculate oscillator strength between the ASFs ! - CALL CSFM (ASFAtmp,ASFBtmp,LEVII,LEVFF) + CALL CSFM (ASFAtmp,ASFBtmp,LEVII,LEVFF) CALL MPI_ALLREDUCE(ASFAtmp,ASFA,1,MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) CALL MPI_ALLREDUCE(ASFBtmp,ASFB,1,MPI_DOUBLE_PRECISION, & MPI_SUM, MPI_COMM_WORLD, ierr) if (myid .EQ. 0) THEN CALL PRINTA(ASFA,ASFB,LEVII,LEVFF,OMEGA,FACTOR, & - LINES,LSAME) + LINES,LSAME) IF(IOPEN_STATUS1.EQ.0 .AND. IOPEN_STATUS2 .EQ.0) THEN CALL PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,LEVII,LEVFF,& OMEGA,FACTOR) END IF END IF ! WRITE (24,317) - END DO - END DO - ENDIF + END DO + END DO + ENDIF ! ! Deallocate storage; this is local to OSCL ! - CALL DALLOC (TOTB, 'TOTB', 'OSCL') - CALL DALLOC (TOTC, 'TOTC', 'OSCL') + CALL DALLOC (TOTB, 'TOTB', 'OSCL') + CALL DALLOC (TOTC, 'TOTC', 'OSCL') ! - CALL DALLOC (ET, 'ET', 'OSCL') - CALL DALLOC (ET1, 'ET!', 'OSCL') - CALL DALLOC (IPR, 'IPR', 'OSCL') - CALL DALLOC (IPR1, 'IPR1', 'OSCL') - CALL DALLOC (NEXT, 'NEXT', 'OSCL') + CALL DALLOC (ET, 'ET', 'OSCL') + CALL DALLOC (ET1, 'ET!', 'OSCL') + CALL DALLOC (IPR, 'IPR', 'OSCL') + CALL DALLOC (IPR1, 'IPR1', 'OSCL') + CALL DALLOC (NEXT, 'NEXT', 'OSCL') ! ! Deallocate storage; this is allocated in READMIX ! - CALL DALLOC (EVALFF, 'EVALFF', 'OSCL') - CALL DALLOC (EVECFF, 'EVECFF', 'OSCL') - CALL DALLOC (IVECFF, 'IVECFF', 'OSCL') - CALL DALLOC (IATJPOFF, 'IATJPOFF', 'OSCL') - CALL DALLOC (IASPARFF, 'IASPARFF', 'OSCL') - - END DO - CLOSE(78) + CALL DALLOC (EVALFF, 'EVALFF', 'OSCL') + CALL DALLOC (EVECFF, 'EVECFF', 'OSCL') + CALL DALLOC (IVECFF, 'IVECFF', 'OSCL') + CALL DALLOC (IATJPOFF, 'IATJPOFF', 'OSCL') + CALL DALLOC (IASPARFF, 'IASPARFF', 'OSCL') + + END DO + CLOSE(78) ! ! Deallocate storage; this is allocated in READMIX ! - CALL DALLOC (EVALII, 'EVALII', 'OSCL') - CALL DALLOC (EVECII, 'EVECII', 'OSCL') - CALL DALLOC (IVECII, 'IVECII', 'OSCL') - CALL DALLOC (IATJPOII, 'IATJPOII', 'OSCL') - CALL DALLOC (IASPARII, 'IASPARII', 'OSCL') - - END DO - CLOSE(68) - CLOSE(NFILE2) - END DO - CALL DALLOC (KP, 'KP', 'OSCL') + CALL DALLOC (EVALII, 'EVALII', 'OSCL') + CALL DALLOC (EVECII, 'EVECII', 'OSCL') + CALL DALLOC (IVECII, 'IVECII', 'OSCL') + CALL DALLOC (IATJPOII, 'IATJPOII', 'OSCL') + CALL DALLOC (IASPARII, 'IASPARII', 'OSCL') + + END DO + CLOSE(68) + CLOSE(NFILE2) + END DO + CALL DALLOC (KP, 'KP', 'OSCL') ! ! close and delete duplicated mixing file - IF (LSAME) THEN - IF (INPCI == 0) THEN + IF (LSAME) THEN + IF (INPCI == 0) THEN OPEN(68, FILE=TRIM(FULLNAME(2))//'_CP.cbm') - ELSE - OPEN(68, FILE=TRIM(FULLNAME(2))//'_CP.bm') - ENDIF -!GG CLOSE(68, STATUS='delete') - ENDIF + ELSE + OPEN(68, FILE=TRIM(FULLNAME(2))//'_CP.bm') + ENDIF +!GG CLOSE(68, STATUS='delete') + ENDIF ! CALL ALCNSA (jja, jjb, hb1, hb2, hc1, hc2, hm1, hm2, lab, nptr, nsdim, 3) CALL ALCNTA (isldr, isldr1, xsldr, ntdim, 3) ! ! This was allocated in LOAD ! -! CALL DALLOC (PF, 'QF', 'OSLC') -! CALL DALLOC (QF, 'QF', 'OSCL') -! CALL DALLOC (IVEC, 'IVEC', 'OSCL') -! CALL DALLOC (IATJPO, 'IATJPO', 'OSCL') -! CALL DALLOC (IASPAR, 'IASPAR', 'OSCL') -! CALL DALLOC (EVAL, 'EVAL', 'OSCL') -! CALL DALLOC (EVEC, 'EVEC', 'OSCL') +! CALL DALLOC (PF, 'QF', 'OSLC') +! CALL DALLOC (QF, 'QF', 'OSCL') +! CALL DALLOC (IVEC, 'IVEC', 'OSCL') +! CALL DALLOC (IATJPO, 'IATJPO', 'OSCL') +! CALL DALLOC (IASPAR, 'IASPAR', 'OSCL') +! CALL DALLOC (EVAL, 'EVAL', 'OSCL') +! CALL DALLOC (EVEC, 'EVEC', 'OSCL') ! ! Close all files ! - if (myid .EQ. 0) CLOSE(24) + if (myid .EQ. 0) CLOSE(24) ! - RETURN + RETURN ! - 302 FORMAT(/,' ***** Warning *****') - 303 FORMAT(/,/,' ***** Error in OSCL *****') - 307 FORMAT(/,' Dynamic allocation computed incorrectly: Bug.') - 308 FORMAT(/,/,' Electric 2**(',I2,')-pole transitions') - 309 FORMAT(/,/,' Magnetic 2**(',I2,')-pole transitions') - 310 FORMAT(1X,33('=')) + 302 FORMAT(/,' ***** Warning *****') + 303 FORMAT(/,/,' ***** Error in OSCL *****') + 307 FORMAT(/,' Dynamic allocation computed incorrectly: Bug.') + 308 FORMAT(/,/,' Electric 2**(',I2,')-pole transitions') + 309 FORMAT(/,/,' Magnetic 2**(',I2,')-pole transitions') + 310 FORMAT(1X,33('=')) 311 FORMAT(/,' Upper state Lower state ',8X,'Gauge',8X,'Wavelength'& - ,13X,'Einstein coefficients',13X,'Oscillator') + ,13X,'Einstein coefficients',13X,'Oscillator') 312 FORMAT(81X,'-1',15X,'3 -2 -1',/,' Level J Parity',4X,'Level J ',& 'Parity',21X,'(Angstroms)',10X,'A (s )',9X,'gB (m s J )',7X,& - 'strength gf'/) + 'strength gf'/) 313 FORMAT(' Level J Parity',4X,'Level J Parity',21X,'(Angstroms)',10X,& - 'A (au)',13X,'gB (au)',10X,'strength gf'/) - 314 FORMAT(/,' Upper Lower ') + 'A (au)',13X,'gB (au)',10X,'strength gf'/) + 314 FORMAT(/,' Upper Lower ') 315 FORMAT(' Lev J P',3X,'Lev J P',7X,'E (',A4,')',9X,'A (s-1)',10X,'gf',& - 12X,'S') + 12X,'S') 316 FORMAT(' Level J Parity',4X,'Level J Parity',23X,'(',A4,')',13X,& - 'A (au)',13X,'gB (au)',10X,'strength gf'/) - 317 FORMAT(/,1X,124('+')) + 'A (au)',13X,'gB (au)',10X,'strength gf'/) + 317 FORMAT(/,1X,124('+')) 318 FORMAT(/,/,' Radiative lifetimes '/,' ======================='/,/,& - ' Level Lifetime s (-1)') - 319 FORMAT(1X,I4,6X,'Coulomb: ',1P,1D20.7) - 320 FORMAT(10X,'Babushkin:',1P,1D20.7,/) - 321 FORMAT(1X,I4,5X,'Magnetic: ',1P,1D20.7,/) - RETURN + ' Level Lifetime s (-1)') + 319 FORMAT(1X,I4,6X,'Coulomb: ',1P,1D20.7) + 320 FORMAT(10X,'Babushkin:',1P,1D20.7,/) + 321 FORMAT(1X,I4,5X,'Magnetic: ',1P,1D20.7,/) + RETURN ! - END SUBROUTINE OSCL + END SUBROUTINE OSCL diff --git a/src/appl/rtransition90_mpi/osclmpi_I.f90 b/src/appl/rtransition90_mpi/osclmpi_I.f90 index 06a6231c8..06f25a698 100644 --- a/src/appl/rtransition90_mpi/osclmpi_I.f90 +++ b/src/appl/rtransition90_mpi/osclmpi_I.f90 @@ -1,13 +1,13 @@ - MODULE oscl_I + MODULE oscl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE oscl (NAME,FULLNAME,tmpdir,startdir,idstring) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME + SUBROUTINE oscl (NAME,FULLNAME,tmpdir,startdir,idstring) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(INOUT) :: NAME CHARACTER(LEN=3) :: idstring - CHARACTER (LEN = 128), DIMENSION(2), INTENT(INOUT) :: FULLNAME + CHARACTER (LEN = 128), DIMENSION(2), INTENT(INOUT) :: FULLNAME CHARACTER(LEN=128) :: startdir,tmpdir - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/printa.f90 b/src/appl/rtransition90_mpi/printa.f90 index 2f2770fd4..ea37e9920 100644 --- a/src/appl/rtransition90_mpi/printa.f90 +++ b/src/appl/rtransition90_mpi/printa.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) + SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! * ! This routine prints the basic oscillator strength information * ! for transitions between level I and level J. * @@ -8,19 +8,19 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C - USE CUTO_C + USE CUTO_C USE JLABL_C, LABJ=>JLBR, LABP=> JLBP USE OSC_C - USE SYMA_C - USE PRNT_C + USE SYMA_C + USE PRNT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -29,102 +29,102 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! D u m m y A r g u m e n t s !----------------------------------------------- LOGICAL, INTENT(IN) :: LSAME - INTEGER :: I, J - INTEGER, INTENT(INOUT) :: LINES - REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB - REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR + INTEGER :: I, J + INTEGER, INTENT(INOUT) :: LINES + REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB + REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IPAR, JPAR, ISIGNA, ISIGNB - REAL(DOUBLE), DIMENSION(10) :: DBLFAC + INTEGER :: IPAR, JPAR, ISIGNA, ISIGNB + REAL(DOUBLE), DIMENSION(10) :: DBLFAC REAL(DOUBLE) :: STFAC, DLL1, OMC, FAAU, FOSC, FBAU, ENG, GGFACTOR, & - ACSQ, ABSQ, AC, AB, BC, BB, OSCC, OSCB, SA, SB, AMS, AM, BM, OSCM - CHARACTER(LEN=4) :: JLABI, JLABJ, JPARI, JPARJ + ACSQ, ABSQ, AC, AB, BC, BB, OSCC, OSCB, SA, SB, AMS, AM, BM, OSCM + CHARACTER(LEN=4) :: JLABI, JLABJ, JPARI, JPARJ CHARACTER(LEN=2) :: F1,F2 !----------------------------------------------- ! ! DATA DBLFAC/ 3.0000000000D00, 1.5000000000D01, 1.0500000000D02, & 9.4500000000D02, 1.0395000000D04, 1.3513500000D05, 2.0270250000D06, & - 3.4459425000D07, 6.5472907500D08, 1.3749310575D10/ + 3.4459425000D07, 6.5472907500D08, 1.3749310575D10/ ! ! Evaluate statistical factors and constants ! - STFAC = IATJPOII(I) - DLL1 = DBLE(LK + LK + 1) - STFAC = STFAC/DLL1 + STFAC = IATJPOII(I) + DLL1 = DBLE(LK + LK + 1) + STFAC = STFAC/DLL1 ! - OMC = OMEGA/CVAC + OMC = OMEGA/CVAC ! OMC = OMEGA/C - FAAU = 2.0D00*OMC*STFAC/DBLE(IATJPOFF(J)) - FOSC = CVAC*STFAC/OMC + FAAU = 2.0D00*OMC*STFAC/DBLE(IATJPOFF(J)) + FOSC = CVAC*STFAC/OMC ! FOSC = C*STFAC/OMC - FBAU = PI*FOSC/OMEGA - ENG = OMEGA*FACTOR - IF (LTC(1)) ENG = FACTOR/OMEGA + FBAU = PI*FOSC/OMEGA + ENG = OMEGA*FACTOR + IF (LTC(1)) ENG = FACTOR/OMEGA ! ! J/pi labels for levels ! - JLABI = LABJ(IATJPOII(I)) - JLABJ = LABJ(IATJPOFF(J)) - IPAR = (IASPARII(I) + 3)/2 - JPAR = (IASPARFF(J) + 3)/2 - JPARI = LABP(IPAR) - JPARJ = LABP(JPAR) + JLABI = LABJ(IATJPOII(I)) + JLABJ = LABJ(IATJPOFF(J)) + IPAR = (IASPARII(I) + 3)/2 + JPAR = (IASPARFF(J) + 3)/2 + JPARI = LABP(IPAR) + JPARJ = LABP(JPAR) !GG GGFACTOR = CVAC**(2*LK - 2)*DBLE(LK)*DBLFAC(LK)**2/((2.0D00*DBLE(LK) + & - 1.0D00)*(DBLE(LK) + 1.0D00)*ABS(OMEGA)**(2*LK - 1)) + 1.0D00)*(DBLE(LK) + 1.0D00)*ABS(OMEGA)**(2*LK - 1)) !GG-end ! ! Calculate Einstein A and B coefficients and oscillator strengths ! - IF (KK == 0) THEN + IF (KK == 0) THEN ! ! Electric multipoles ! ! In atomic units ! - IF (ASFA < 0) THEN - ISIGNA = -1 - ELSE - ISIGNA = 1 - ENDIF - IF (ASFB < 0) THEN - ISIGNB = -1 - ELSE - ISIGNB = 1 - ENDIF - - ACSQ = ASFA**2 - ABSQ = ASFB**2 - AC = ACSQ*FAAU - AB = ABSQ*FAAU - BC = ACSQ*FBAU - BB = ABSQ*FBAU - OSCC = ACSQ*FOSC - OSCB = ABSQ*FOSC - SA = OSCC*GGFACTOR - SB = OSCB*GGFACTOR + IF (ASFA < 0) THEN + ISIGNA = -1 + ELSE + ISIGNA = 1 + ENDIF + IF (ASFB < 0) THEN + ISIGNB = -1 + ELSE + ISIGNB = 1 + ENDIF + + ACSQ = ASFA**2 + ABSQ = ASFB**2 + AC = ACSQ*FAAU + AB = ABSQ*FAAU + BC = ACSQ*FBAU + BB = ABSQ*FBAU + OSCC = ACSQ*FOSC + OSCB = ABSQ*FOSC + SA = OSCC*GGFACTOR + SB = OSCB*GGFACTOR !GG-end ! ! Convert to SI units if option 5 not set ! - IF (.NOT.LTC(7)) THEN - AC = AC*FASI - AB = AB*FASI - BC = BC*FBSI - BB = BB*FBSI - ENDIF + IF (.NOT.LTC(7)) THEN + AC = AC*FASI + AB = AB*FASI + BC = BC*FBSI + BB = BB*FBSI + ENDIF ! ! Accumulate total of A coefficients ! - TOTC(J) = TOTC(J) + AC - TOTB(J) = TOTB(J) + AB + TOTC(J) = TOTC(J) + AC + TOTB(J) = TOTB(J) + AB ! ! Print information if both AC and AB are greater than CUTOFF ! - IF (ABS(AC)>=CUTOFF .AND. ABS(AB)>=CUTOFF) THEN + IF (ABS(AC)>=CUTOFF .AND. ABS(AB)>=CUTOFF) THEN IF (ENG .LT. -1.0d-9) THEN IF (LSAME) THEN F1 = 'f ' @@ -135,8 +135,8 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) END IF ! WRITE (24, 300) F1,IVECFF(J),JLABJ,JPARJ,F2,IVECII(I),JLABI,JPARI, & - -ENG, -AC, -OSCC, -SA !, ASFA - WRITE (24, 301) -AB, -OSCB, -SB !, ASFB + -ENG, -AC, -OSCC, -SA !, ASFA + WRITE (24, 301) -AB, -OSCB, -SB !, ASFB ELSE IF (ENG .GT. 1.D-9) THEN IF (LSAME) THEN F1 = 'f ' @@ -150,41 +150,41 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) OSCC,SA WRITE (24,301) AB*IATJPOFF(J)/IATJPOII(I),OSCB,SB END IF - LINES = LINES + 3 - ENDIF + LINES = LINES + 3 + ENDIF ! - ELSE + ELSE ! ! Magnetic multipoles ! ! In atomic units ! - IF (ASFA < 0) THEN - ISIGNA = -1 - ELSE - ISIGNA = 1 - ENDIF - AMS = ASFA**2 - AM = AMS*FAAU - BM = AMS*FBAU - OSCM = AMS*FOSC - SA = OSCM*GGFACTOR*CVAC*CVAC*4 + IF (ASFA < 0) THEN + ISIGNA = -1 + ELSE + ISIGNA = 1 + ENDIF + AMS = ASFA**2 + AM = AMS*FAAU + BM = AMS*FBAU + OSCM = AMS*FOSC + SA = OSCM*GGFACTOR*CVAC*CVAC*4 ! ! Convert to SI units if option 5 not set ! - IF (.NOT.LTC(7)) THEN - AM = AM*FASI - BM = AM*FBSI - ENDIF + IF (.NOT.LTC(7)) THEN + AM = AM*FASI + BM = AM*FBSI + ENDIF ! ! Accumulate total of A coefficients ! - TOTC(J) = TOTC(J) + AM - TOTB(J) = TOTB(J) + AM + TOTC(J) = TOTC(J) + AM + TOTB(J) = TOTB(J) + AM ! ! Print information if AM is greater than CUTOFF ! - IF (ABS(AM) >= CUTOFF) THEN + IF (ABS(AM) >= CUTOFF) THEN IF (ENG .LE. -1.0D-9) THEN IF (LSAME) THEN F1 = 'f ' @@ -210,9 +210,9 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) LINES = LINES+2 ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! !cjb format for highly charged ions F11.2 -> F13.2 ! 300 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,0P,F11.2,' C',1P, & @@ -223,6 +223,6 @@ SUBROUTINE PRINTA(ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) ! 302 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,0P,F11.2,' M',1P, & 302 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,0P,F13.2,' M',1P, & 3D13.5) - RETURN + RETURN ! - END SUBROUTINE PRINTA + END SUBROUTINE PRINTA diff --git a/src/appl/rtransition90_mpi/printaLS.f90 b/src/appl/rtransition90_mpi/printaLS.f90 index 0c7a1d8b7..8eea54d7c 100644 --- a/src/appl/rtransition90_mpi/printaLS.f90 +++ b/src/appl/rtransition90_mpi/printaLS.f90 @@ -9,10 +9,10 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) ! NIST May 2011 * ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE def_C @@ -52,7 +52,7 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) print*, ' ' print*, ' INCORRECT INPUT, PROGRAM STOP!!! ' print*, ' ' - print*, ' lsj.lbl files from the jj2lsj runs are inconsistent ' + print*, ' lsj.lbl files from the jj2lsj runs are inconsistent ' print*, ' with the files used in the bioscl calculation. ' print*, ' The bioscl calculation was for rci wave functions ' print*, ' but the jj2lsj run was for rscf wave functions or ' @@ -67,8 +67,8 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) print*, ' Then rerun rtransition. ' STOP END IF - DD = D*AUCM - ANGS = 1.0D08 / DD + DD = D*AUCM + ANGS = 1.0D08 / DD ANGSA = ANGS IF(ANGS .GT. 2000.D0) THEN SIGMA = (1.D8/ANGS)**2 @@ -268,7 +268,7 @@ SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) END IF WRITE (32,40) DD,ANGS,ANGSA, & IM,LK,SA,OSCM,AM*IATJPOFF(J)/IATJPOII(I) - END IF + END IF ENDIF ENDIF RETURN diff --git a/src/appl/rtransition90_mpi/printaLS_I.f90 b/src/appl/rtransition90_mpi/printaLS_I.f90 index 157d1ea8c..ac2b51bb0 100644 --- a/src/appl/rtransition90_mpi/printaLS_I.f90 +++ b/src/appl/rtransition90_mpi/printaLS_I.f90 @@ -1,12 +1,12 @@ - MODULE printaLS_I + MODULE printaLS_I INTERFACE SUBROUTINE PRINTALS (INUM_II,INUM_FF,ASFA,ASFB,I,J,OMEGA,FACTOR) -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - USE vast_kind_param,ONLY: DOUBLE + USE vast_kind_param,ONLY: DOUBLE INTEGER :: I, J, INUM_II, INUM_FF REAL(DOUBLE), INTENT(IN) :: ASFA, ASFB REAL(DOUBLE), INTENT(IN) :: OMEGA, FACTOR - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/printa_I.f90 b/src/appl/rtransition90_mpi/printa_I.f90 index 00e3a7a26..01bdf0cdb 100644 --- a/src/appl/rtransition90_mpi/printa_I.f90 +++ b/src/appl/rtransition90_mpi/printa_I.f90 @@ -1,18 +1,18 @@ - MODULE printa_I + MODULE printa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE printa (ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE printa (ASFA, ASFB, I, J, OMEGA, FACTOR, LINES, LSAME) + USE vast_kind_param,ONLY: DOUBLE LOGICAL, INTENT(IN) :: LSAME - REAL(DOUBLE), INTENT(IN) :: ASFA - REAL(DOUBLE), INTENT(IN) :: ASFB - INTEGER :: I - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(IN) :: OMEGA - REAL(DOUBLE), INTENT(IN) :: FACTOR - INTEGER, INTENT(INOUT) :: LINES - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), INTENT(IN) :: ASFA + REAL(DOUBLE), INTENT(IN) :: ASFB + INTEGER :: I + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(IN) :: OMEGA + REAL(DOUBLE), INTENT(IN) :: FACTOR + INTEGER, INTENT(INOUT) :: LINES + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/readmixmpi.f90 b/src/appl/rtransition90_mpi/readmixmpi.f90 index 71073108a..06136040a 100644 --- a/src/appl/rtransition90_mpi/readmixmpi.f90 +++ b/src/appl/rtransition90_mpi/readmixmpi.f90 @@ -1,19 +1,19 @@ !*********************************************************************** ! * - SUBROUTINE READMIX(NAME, INPCI, INIT) + SUBROUTINE READMIX(NAME, INPCI, INIT) ! * ! Open and read the mixing coefficent files * ! * ! Written by Per Jonsson * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE biorb_C USE def_C @@ -28,57 +28,57 @@ SUBROUTINE READMIX(NAME, INPCI, INIT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: INPCI - INTEGER , INTENT(IN) :: INIT + INTEGER :: INPCI + INTEGER , INTENT(IN) :: INIT CHARACTER :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IB, IATJP, IASPA, I, J - CHARACTER :: G92MIX*6 + INTEGER :: IB, IATJP, IASPA, I, J + CHARACTER :: G92MIX*6 !----------------------------------------------- ! - IF (INIT == 1) THEN + IF (INIT == 1) THEN ! ! Read the initial state mixing file ! - READ (68) IB, NCFII, NVECII, IATJP, IASPA - CALL ALLOC (EVALII, NVECII, 'EVALII', 'READMIX') - CALL ALLOC (EVECII, NCFII*NVECII, 'EVECII', 'READMIX') - CALL ALLOC (IVECII, NVECII,'IVECII', 'READMIX' ) - CALL ALLOC (IATJPOII, NVECII, 'IATJPOII', 'READMIX') - CALL ALLOC (IASPARII, NVECII, 'ISPARII', 'READMIX') - READ (68) (IVECII(I),I=1,NVECII) - IATJPOII(:NVECII) = IATJP - IASPARII(:NVECII) = IASPA - READ (68) EAVII, (EVALII(I),I=1,NVECII) - - READ (68) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) + READ (68) IB, NCFII, NVECII, IATJP, IASPA + CALL ALLOC (EVALII, NVECII, 'EVALII', 'READMIX') + CALL ALLOC (EVECII, NCFII*NVECII, 'EVECII', 'READMIX') + CALL ALLOC (IVECII, NVECII,'IVECII', 'READMIX' ) + CALL ALLOC (IATJPOII, NVECII, 'IATJPOII', 'READMIX') + CALL ALLOC (IASPARII, NVECII, 'ISPARII', 'READMIX') + READ (68) (IVECII(I),I=1,NVECII) + IATJPOII(:NVECII) = IATJP + IASPARII(:NVECII) = IASPA + READ (68) EAVII, (EVALII(I),I=1,NVECII) + + READ (68) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) ! ! CLOSE(68) ! - ELSE + ELSE ! ! Read the final state mixing file ! - - READ (78) IB, NCFFF, NVECFF, IATJP, IASPA - CALL ALLOC (EVALFF, NVECFF, 'EVALFF', 'READMIX') - CALL ALLOC (EVECFF, NCFFF*NVECFF, 'EVECFF', 'READMIX') - CALL ALLOC (IVECFF, NVECFF,'IVECFF', 'READMIX' ) - CALL ALLOC (IATJPOFF, NVECFF, 'IATJPOFF', 'READMIX') - CALL ALLOC (IASPARFF, NVECFF, 'ISPARFF', 'READMIX') - READ (78) (IVECFF(I),I=1,NVECFF) - IATJPOFF(:NVECFF) = IATJP - IASPARFF(:NVECFF) = IASPA - READ (78) EAVFF, (EVALFF(I),I=1,NVECFF) - - READ (78) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) + + READ (78) IB, NCFFF, NVECFF, IATJP, IASPA + CALL ALLOC (EVALFF, NVECFF, 'EVALFF', 'READMIX') + CALL ALLOC (EVECFF, NCFFF*NVECFF, 'EVECFF', 'READMIX') + CALL ALLOC (IVECFF, NVECFF,'IVECFF', 'READMIX' ) + CALL ALLOC (IATJPOFF, NVECFF, 'IATJPOFF', 'READMIX') + CALL ALLOC (IASPARFF, NVECFF, 'ISPARFF', 'READMIX') + READ (78) (IVECFF(I),I=1,NVECFF) + IATJPOFF(:NVECFF) = IATJP + IASPARFF(:NVECFF) = IASPA + READ (78) EAVFF, (EVALFF(I),I=1,NVECFF) + + READ (78) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) ! ! Close the initial state mixing file ! ! CLOSE(78) - ENDIF - - RETURN - END SUBROUTINE READMIX + ENDIF + + RETURN + END SUBROUTINE READMIX diff --git a/src/appl/rtransition90_mpi/readmixmpi_I.f90 b/src/appl/rtransition90_mpi/readmixmpi_I.f90 index 96a557972..b4248beef 100644 --- a/src/appl/rtransition90_mpi/readmixmpi_I.f90 +++ b/src/appl/rtransition90_mpi/readmixmpi_I.f90 @@ -1,12 +1,12 @@ - MODULE readmix_I + MODULE readmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:04:38 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE readmix (NAME, INPCI, INIT) - CHARACTER (LEN = 24), DIMENSION(2) :: NAME - INTEGER :: INPCI - INTEGER, INTENT(IN) :: INIT - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE readmix (NAME, INPCI, INIT) + CHARACTER (LEN = 24), DIMENSION(2) :: NAME + INTEGER :: INPCI + INTEGER, INTENT(IN) :: INIT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/setcsl.f90 b/src/appl/rtransition90_mpi/setcsl.f90 index 1d4583c83..1f2e8a6ba 100644 --- a/src/appl/rtransition90_mpi/setcsl.f90 +++ b/src/appl/rtransition90_mpi/setcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSL + SUBROUTINE SETCSL ! * ! Open, check, load data from and close the .csl file. This file * ! is always attached to stream 21. * @@ -10,62 +10,62 @@ SUBROUTINE SETCSL ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcsl_I + USE openfl_I + USE lodcsl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS, NCORE - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: IERR, IOS, NCORE + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! ! The .csl file is FORMATTED; it must exist ! - DEFNAM = 'rcsl.inp' - FORM = 'FORMATTED' - STATUS = 'OLD' + DEFNAM = 'rcsl.inp' + FORM = 'FORMATTED' + STATUS = 'OLD' ! ! Look for grasp92.csl ! - INQUIRE(FILE=DEFNAM, EXIST=FOUND) + INQUIRE(FILE=DEFNAM, EXIST=FOUND) ! - IF (FOUND) THEN - FILNAM = DEFNAM - ELSE - WRITE (6, *) 'rcsl.inp does not exist' - STOP - ENDIF + IF (FOUND) THEN + FILNAM = DEFNAM + ELSE + WRITE (6, *) 'rcsl.inp does not exist' + STOP + ENDIF ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening rcsl.inp' - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening rcsl.inp' + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSL (NCORE) + CALL LODCSL (NCORE) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN - END SUBROUTINE SETCSL + RETURN + END SUBROUTINE SETCSL diff --git a/src/appl/rtransition90_mpi/setcsl_I.f90 b/src/appl/rtransition90_mpi/setcsl_I.f90 index 7d4331f94..c9303318c 100644 --- a/src/appl/rtransition90_mpi/setcsl_I.f90 +++ b/src/appl/rtransition90_mpi/setcsl_I.f90 @@ -1,9 +1,9 @@ - MODULE setcsl_I + MODULE setcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsl - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcsl + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/setcslm.f90 b/src/appl/rtransition90_mpi/setcslm.f90 index f32c1c590..306329a70 100644 --- a/src/appl/rtransition90_mpi/setcslm.f90 +++ b/src/appl/rtransition90_mpi/setcslm.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLM + SUBROUTINE SETCSLM ! * ! Open, check, load data from and close the .csl file. This file * ! is always attached to stream 21. * @@ -10,62 +10,62 @@ SUBROUTINE SETCSLM ! Written by Farid A. Parpia Last revision: 23 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcslm_I + USE openfl_I + USE lodcslm_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS, NCORE - LOGICAL :: FOUND - CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: IERR, IOS, NCORE + LOGICAL :: FOUND + CHARACTER :: FILNAM*256, RECORD*15, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! ! The .csl file is FORMATTED; it must exist ! - DEFNAM = 'SLASK' - FORM = 'FORMATTED' - STATUS = 'OLD' + DEFNAM = 'SLASK' + FORM = 'FORMATTED' + STATUS = 'OLD' ! ! Look for grasp92.csl ! - INQUIRE(FILE=DEFNAM, EXIST=FOUND) + INQUIRE(FILE=DEFNAM, EXIST=FOUND) ! - IF (FOUND) THEN - FILNAM = DEFNAM - ELSE - WRITE (6, *) 'rcsl.inp does not exist' - STOP - ENDIF + IF (FOUND) THEN + FILNAM = DEFNAM + ELSE + WRITE (6, *) 'rcsl.inp does not exist' + STOP + ENDIF ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening rcsl.inp' - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening rcsl.inp' + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(21, STATUS='DELETE') - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(21, STATUS='DELETE') + ENDIF ! ! Load data from the .csl file ! - CALL LODCSLM (NCORE) + CALL LODCSLM (NCORE) ! ! Close the .csl file ! - CLOSE(21, STATUS='DELETE') + CLOSE(21, STATUS='DELETE') ! - RETURN - END SUBROUTINE SETCSLM + RETURN + END SUBROUTINE SETCSLM diff --git a/src/appl/rtransition90_mpi/setcslm_I.f90 b/src/appl/rtransition90_mpi/setcslm_I.f90 index aa7b321a3..2b998020f 100644 --- a/src/appl/rtransition90_mpi/setcslm_I.f90 +++ b/src/appl/rtransition90_mpi/setcslm_I.f90 @@ -1,9 +1,9 @@ - MODULE setcslm_I + MODULE setcslm_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcslm - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setcslm + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/spme.f90 b/src/appl/rtransition90_mpi/spme.f90 index 5cdbdbc70..a05ee136d 100644 --- a/src/appl/rtransition90_mpi/spme.f90 +++ b/src/appl/rtransition90_mpi/spme.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) + SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) ! * ! This routine calculates the reduced matrix elements for pair I,J * ! in either Coulomb/Babuskin gauge or for magnetic case. * @@ -10,13 +10,13 @@ SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) ! ative transitions paper. * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:05:40 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:05:40 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE bess_C USE biorb_C USE debug_C @@ -29,253 +29,253 @@ SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I - USE quad_I + USE clrx_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: I,J - REAL(DOUBLE), INTENT(OUT) :: HCOUL, HBAB, HMAG + INTEGER, INTENT(IN) :: I,J + REAL(DOUBLE), INTENT(OUT) :: HCOUL, HBAB, HMAG !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NKJI, NKJJ, IPJ, NAKI, NAKJ, II, LP, LM + INTEGER :: NKJI, NKJJ, IPJ, NAKI, NAKJ, II, LP, LM REAL(DOUBLE) :: EPS, HGAUGE, TJI, TJJ, FACT, FORM, FL, FLP, DFKI, DFKJ, & CLP, CLM, CIPLP, CIMLP, CIPLM, CIMLM, VALUE, CJL, CIP, TAROM, ESTHER, & TEKEL, PERES, TAMAR, ENOCH, SETH, SHEM, DARIUS, CYRUS, DANIEL, BOAZ, & - ESAU, AARON, GIMEL + ESAU, AARON, GIMEL !----------------------------------------------- - + ! - EPS = 1.0D-10 + EPS = 1.0D-10 ! IF (LDBPR(12) .OR. LDBPR(13) .OR. LDBPR(14) .OR. LDBPR(15)) WRITE (99, & - 303) I, J + 303) I, J ! - HMAG = 0.0D00 - HCOUL = 0.0D00 - HGAUGE = 0.0D00 - HBAB = 0.0D00 + HMAG = 0.0D00 + HCOUL = 0.0D00 + HGAUGE = 0.0D00 + HBAB = 0.0D00 ! ! Evaluate factor multiplying Mbar(a,b) ! - NKJI = NKJ(I) - NKJJ = NKJ(J) - TJI = DBLE(NKJI) - TJJ = DBLE(NKJJ) - FACT = 1.0D00 - IPJ = (NKJI + 1)/2 + NKJJ - IF (MOD(IPJ,2) /= 0) FACT = -FACT - NAKI = NAK(I) - NAKJ = NAK(J) - FORM = FACT*SQRT(TJJ + 1.0D00)*CLRX(NAKJ,LK,NAKI) - FL = DBLE(LK) - FLP = FL + 1.0D00 - DFKI = DBLE(NAKI) - DFKJ = DBLE(NAKJ) + NKJI = NKJ(I) + NKJJ = NKJ(J) + TJI = DBLE(NKJI) + TJJ = DBLE(NKJJ) + FACT = 1.0D00 + IPJ = (NKJI + 1)/2 + NKJJ + IF (MOD(IPJ,2) /= 0) FACT = -FACT + NAKI = NAK(I) + NAKJ = NAK(J) + FORM = FACT*SQRT(TJJ + 1.0D00)*CLRX(NAKJ,LK,NAKI) + FL = DBLE(LK) + FLP = FL + 1.0D00 + DFKI = DBLE(NAKI) + DFKJ = DBLE(NAKJ) ! - MTP = MIN(MFII(NNII(I)),MFFF(NNFF(J))) + MTP = MIN(MFII(NNII(I)),MFFF(NNFF(J))) ! - IF (KK == 0) THEN + IF (KK == 0) THEN ! - IF (ABS(FORM) > EPS) THEN + IF (ABS(FORM) > EPS) THEN ! ! To pick the right initial and final state radial functions convert ! from orbital order of the merged list to the orbital orders of the ! initial and final state lists, respectively. ! N(I) -> NNII(I), N(J) -> NNFF(J) ! - DO II = 1, N + DO II = 1, N TB(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) + QFII(II,NNII(I))*& - PFFF(II,NNFF(J)) + PFFF(II,NNFF(J)) TC(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) - QFII(II,NNII(I))*& - PFFF(II,NNFF(J)) + PFFF(II,NNFF(J)) ! zou - TB(II) = TB(II)*C/CVAC - TC(II) = TC(II)*C/CVAC + TB(II) = TB(II)*C/CVAC + TC(II) = TC(II)*C/CVAC TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) + QFII(II,NNII(I))*& - QFFF(II,NNFF(J))*(C/CVAC)**2 + QFFF(II,NNFF(J))*(C/CVAC)**2 ! TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) + ! : QFII(II,NNII(I))*QFFF(II,NNFF(J)) ! zou - END DO - LP = LK + 1 - LM = LK - 1 + END DO + LP = LK + 1 + LM = LK - 1 ! ! Calculate Coulomb coefficients ! - CLP = SQRT(FL/FLP) - CLM = -SQRT(FLP/FL) - CIPLP = CLP*(DFKI - DFKJ) - CIMLP = CLP*FLP - CIPLM = CLM*(DFKI - DFKJ) - CIMLM = -CLM*FL + CLP = SQRT(FL/FLP) + CLM = -SQRT(FLP/FL) + CIPLP = CLP*(DFKI - DFKJ) + CIMLP = CLP*FLP + CIPLM = CLM*(DFKI - DFKJ) + CIMLM = -CLM*FL ! ! Tabulate Coulomb integrand ! - TA(1) = 0.0D00 + TA(1) = 0.0D00 TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,3)*(CIPLP*TB(2:MTP)+CIMLP*TC(2:MTP)& - )+BJ(2:MTP,1)*(CIPLM*TB(2:MTP)+CIMLM*TC(2:MTP))) - CALL QUAD (VALUE) - HCOUL = FORM*VALUE + )+BJ(2:MTP,1)*(CIPLM*TB(2:MTP)+CIMLM*TC(2:MTP))) + CALL QUAD (VALUE) + HCOUL = FORM*VALUE ! ! Calculate gauge dependent coefficients ! - CJL = -(FL + FLP) - CIP = DFKI - DFKJ + CJL = -(FL + FLP) + CIP = DFKI - DFKJ ! ! Tabulate gauge dependent integrand ! - TA(1) = 0.0D00 + TA(1) = 0.0D00 TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,2)*(CJL*TD(2:MTP))+BJ(2:MTP,3)*(CIP& *TB(2:MTP)+FLP*TC(2:MTP))+BJ(2:MTP,1)*(CIP*TB(2:MTP)-FL*TC(2:MTP& - ))) + ))) ! ! Print gauge dependent integrand if requested ! - IF (LDBPR(13)) WRITE (99, 300) I, J, (II,TA(II),II=1,N) - CALL QUAD (VALUE) - HGAUGE = FORM*VALUE - HBAB = HCOUL + SQRT(FLP/FL)*HGAUGE + IF (LDBPR(13)) WRITE (99, 300) I, J, (II,TA(II),II=1,N) + CALL QUAD (VALUE) + HGAUGE = FORM*VALUE + HBAB = HCOUL + SQRT(FLP/FL)*HGAUGE ! ! Print Coulomb and gauge dependent integrals if requested ! - IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB + IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB ! ! Calculate the contibutions from various terms if requested ! - IF (LDBPR(14) .OR. LDBPR(15)) THEN -! - TA(1) = 0.0D00 - TA(2:MTP) = TD(2:MTP)*BJ(2:MTP,2)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (TAROM) - IF (LDBPR(14)) WRITE (99, 305) TAROM - ESTHER = -CJL - IF (LDBPR(14)) WRITE (99, 306) ESTHER - TEKEL = ESTHER*TAROM - IF (LDBPR(14)) WRITE (99, 307) TEKEL -! - TA(1) = 0.0D00 - TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,3)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (PERES) - IF (LDBPR(14)) THEN - WRITE (99, 308) PERES - WRITE (99, 306) CIP - ENDIF - TAMAR = CIP*PERES - IF (LDBPR(14)) WRITE (99, 307) TAMAR -! - TA(1) = 0.0D00 - TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,1)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (ENOCH) - IF (LDBPR(14)) THEN - WRITE (99, 309) ENOCH - WRITE (99, 306) CIP - ENDIF - SETH = CIP*ENOCH - IF (LDBPR(14)) WRITE (99, 307) SETH -! - TA(1) = 0.0D00 - TA(2:MTP) = BJ(2:MTP,1)*TC(2:MTP)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (SHEM) - IF (LDBPR(14)) THEN - WRITE (99, 310) SHEM - WRITE (99, 306) FL - ENDIF - DARIUS = FL*SHEM - IF (LDBPR(14)) WRITE (99, 307) DARIUS -! - TA(1) = 0.0D00 - TA(2:MTP) = -BJ(2:MTP,3)*TC(2:MTP)*RP(2:MTP) - IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) - CALL QUAD (CYRUS) - IF (LDBPR(14)) WRITE (99, 311) CYRUS - DANIEL = FLP - IF (LDBPR(14)) WRITE (99, 306) DANIEL - BOAZ = DANIEL*CYRUS - IF (LDBPR(14)) WRITE (99, 307) BOAZ -! - ESAU = TAMAR + SETH + DARIUS + BOAZ - IF (LDBPR(14)) WRITE (99, 312) ESAU, TEKEL - AARON = ESAU + TEKEL - GIMEL = -VALUE - IF (LDBPR(14)) THEN - WRITE (99, 313) AARON, GIMEL - WRITE (99, 314) - WRITE (99, 315) PERES, CIP, TAMAR - WRITE (99, 316) ENOCH, CIP, SETH - WRITE (99, 317) SHEM, FL, DARIUS - WRITE (99, 318) CYRUS, DANIEL, BOAZ - WRITE (99, 319) ESAU - WRITE (99, 320) TAROM, ESTHER, TEKEL - WRITE (99, 321) GIMEL, AARON - ENDIF -! - ENDIF -! - ENDIF -! - IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB -! - ELSE + IF (LDBPR(14) .OR. LDBPR(15)) THEN +! + TA(1) = 0.0D00 + TA(2:MTP) = TD(2:MTP)*BJ(2:MTP,2)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (TAROM) + IF (LDBPR(14)) WRITE (99, 305) TAROM + ESTHER = -CJL + IF (LDBPR(14)) WRITE (99, 306) ESTHER + TEKEL = ESTHER*TAROM + IF (LDBPR(14)) WRITE (99, 307) TEKEL +! + TA(1) = 0.0D00 + TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,3)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (PERES) + IF (LDBPR(14)) THEN + WRITE (99, 308) PERES + WRITE (99, 306) CIP + ENDIF + TAMAR = CIP*PERES + IF (LDBPR(14)) WRITE (99, 307) TAMAR +! + TA(1) = 0.0D00 + TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,1)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (ENOCH) + IF (LDBPR(14)) THEN + WRITE (99, 309) ENOCH + WRITE (99, 306) CIP + ENDIF + SETH = CIP*ENOCH + IF (LDBPR(14)) WRITE (99, 307) SETH +! + TA(1) = 0.0D00 + TA(2:MTP) = BJ(2:MTP,1)*TC(2:MTP)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (SHEM) + IF (LDBPR(14)) THEN + WRITE (99, 310) SHEM + WRITE (99, 306) FL + ENDIF + DARIUS = FL*SHEM + IF (LDBPR(14)) WRITE (99, 307) DARIUS +! + TA(1) = 0.0D00 + TA(2:MTP) = -BJ(2:MTP,3)*TC(2:MTP)*RP(2:MTP) + IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N) + CALL QUAD (CYRUS) + IF (LDBPR(14)) WRITE (99, 311) CYRUS + DANIEL = FLP + IF (LDBPR(14)) WRITE (99, 306) DANIEL + BOAZ = DANIEL*CYRUS + IF (LDBPR(14)) WRITE (99, 307) BOAZ +! + ESAU = TAMAR + SETH + DARIUS + BOAZ + IF (LDBPR(14)) WRITE (99, 312) ESAU, TEKEL + AARON = ESAU + TEKEL + GIMEL = -VALUE + IF (LDBPR(14)) THEN + WRITE (99, 313) AARON, GIMEL + WRITE (99, 314) + WRITE (99, 315) PERES, CIP, TAMAR + WRITE (99, 316) ENOCH, CIP, SETH + WRITE (99, 317) SHEM, FL, DARIUS + WRITE (99, 318) CYRUS, DANIEL, BOAZ + WRITE (99, 319) ESAU + WRITE (99, 320) TAROM, ESTHER, TEKEL + WRITE (99, 321) GIMEL, AARON + ENDIF +! + ENDIF +! + ENDIF +! + IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB +! + ELSE ! ! Tabulate magnetic integrand ! - IF (ABS(FORM) > EPS) THEN + IF (ABS(FORM) > EPS) THEN ! - TA(1) = 0.0D00 - DO II = 2, MTP + TA(1) = 0.0D00 + DO II = 2, MTP !zou TA(II) = (PFII(II,NNII(I))*QFFF(II,NNFF(J))+QFII(II,NNII(I))*& - PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)*C/CVAC + PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)*C/CVAC ! TA(II) = (PFII(II,NNII(I))*QFFF(II,NNFF(J)) + ! : QFII(II,NNII(I))*PFFF(II,NNFF(J)))*BJ(II,2)*RP(II) !zou - END DO - CALL QUAD (VALUE) - IF (LDBPR(14)) WRITE (99, 322) VALUE - HMAG = -VALUE*(FL + FLP)*(DFKI + DFKJ)*FORM/SQRT(FL*FLP) + END DO + CALL QUAD (VALUE) + IF (LDBPR(14)) WRITE (99, 322) VALUE + HMAG = -VALUE*(FL + FLP)*(DFKI + DFKJ)*FORM/SQRT(FL*FLP) ! - ENDIF + ENDIF ! - IF (LDBPR(12)) WRITE (99, 302) HMAG + IF (LDBPR(12)) WRITE (99, 302) HMAG ! - ENDIF + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,1X,20X,'Local form of gauge dependent integral for',' orbitals',& - I3,' and',I3,/,/,100(1X,7(I3,2X,1P,D11.3,2X),/)) + I3,' and',I3,/,/,100(1X,7(I3,2X,1P,D11.3,2X),/)) 301 FORMAT(/,1X,'Orbital pair (',I2,',',I2,') integrals:','Coul. gauge ',1P,D& - 13.3,3X,'Gauge contribution',D13.3,3X,'Bab.gauge',D13.3) - 302 FORMAT(/,1X,'Magnetic single particle matrix element ',1P,D13.3) + 13.3,3X,'Gauge contribution',D13.3,3X,'Bab.gauge',D13.3) + 302 FORMAT(/,1X,'Magnetic single particle matrix element ',1P,D13.3) 303 FORMAT(/,1X,30('+'),' SPME called for orbitals ',I4,' and',I4,3X,30(& - '+')) - 304 FORMAT(/,100(1X,7(I3,2X,1P,D11.3,2X),/),/) - 305 FORMAT(/,' Integral J(L) = ',1P,D28.12) - 306 FORMAT(' Factor multiplying this ',1P,D20.12) - 307 FORMAT(' Resultant contribution ',1P,D20.12,/) - 308 FORMAT(' I + (L+1) integral = ',1P,D24.12) - 309 FORMAT(' I + (L-1) integral = ',1P,D24.12) - 310 FORMAT(' I - (L-1) integral = ',1P,D24.12) - 311 FORMAT(' I - (L+1) integral = ',1P,D24.12) + '+')) + 304 FORMAT(/,100(1X,7(I3,2X,1P,D11.3,2X),/),/) + 305 FORMAT(/,' Integral J(L) = ',1P,D28.12) + 306 FORMAT(' Factor multiplying this ',1P,D20.12) + 307 FORMAT(' Resultant contribution ',1P,D20.12,/) + 308 FORMAT(' I + (L+1) integral = ',1P,D24.12) + 309 FORMAT(' I + (L-1) integral = ',1P,D24.12) + 310 FORMAT(' I - (L-1) integral = ',1P,D24.12) + 311 FORMAT(' I - (L+1) integral = ',1P,D24.12) 312 FORMAT(' These last four add up to ',1P,D20.12,& - ' compared to the first which is ',D20.12) - 313 FORMAT(' These all add up to ',1P,D20.12,' which should equal ',D20.12) - 314 FORMAT(/,18X,'Integral',11X,'Coefficient',8X,'Contribution') - 315 FORMAT(' I + (L+1)',1P,3D20.10) - 316 FORMAT(' I + (L-1)',1P,3D20.10) - 317 FORMAT(' I - (L-1)',1P,3D20.10) - 318 FORMAT(' I - (L+1)',1P,3D20.10) - 319 FORMAT(54X,16('-'),/,50X,1P,D20.10) - 320 FORMAT(' J (L)',4X,1P,3D20.10) - 321 FORMAT(54X,16('-'),/,' Correct figure',1P,D20.10,15X,D20.10) - 322 FORMAT(' I + (L) integral',1P,D20.10) - RETURN -! - END SUBROUTINE SPME + ' compared to the first which is ',D20.12) + 313 FORMAT(' These all add up to ',1P,D20.12,' which should equal ',D20.12) + 314 FORMAT(/,18X,'Integral',11X,'Coefficient',8X,'Contribution') + 315 FORMAT(' I + (L+1)',1P,3D20.10) + 316 FORMAT(' I + (L-1)',1P,3D20.10) + 317 FORMAT(' I - (L-1)',1P,3D20.10) + 318 FORMAT(' I - (L+1)',1P,3D20.10) + 319 FORMAT(54X,16('-'),/,50X,1P,D20.10) + 320 FORMAT(' J (L)',4X,1P,3D20.10) + 321 FORMAT(54X,16('-'),/,' Correct figure',1P,D20.10,15X,D20.10) + 322 FORMAT(' I + (L) integral',1P,D20.10) + RETURN +! + END SUBROUTINE SPME diff --git a/src/appl/rtransition90_mpi/spme_I.f90 b/src/appl/rtransition90_mpi/spme_I.f90 index a9721d812..27c59fd2d 100644 --- a/src/appl/rtransition90_mpi/spme_I.f90 +++ b/src/appl/rtransition90_mpi/spme_I.f90 @@ -1,15 +1,15 @@ - MODULE spme_I + MODULE spme_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spme (I, J, HCOUL, HBAB, HMAG) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: HCOUL - REAL(DOUBLE), INTENT(OUT) :: HBAB - REAL(DOUBLE), INTENT(OUT) :: HMAG - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE spme (I, J, HCOUL, HBAB, HMAG) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: HCOUL + REAL(DOUBLE), INTENT(OUT) :: HBAB + REAL(DOUBLE), INTENT(OUT) :: HMAG + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/strsum.f90 b/src/appl/rtransition90_mpi/strsum.f90 index f60b21a74..b99bed4da 100644 --- a/src/appl/rtransition90_mpi/strsum.f90 +++ b/src/appl/rtransition90_mpi/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM(NAME, INPCI, ILBL) + SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! * ! Generates the first part of oscl92.sum (on stream 24). * ! * @@ -9,13 +9,13 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE decide_C USE def_C @@ -32,27 +32,27 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INPCI - INTEGER :: ILBL - CHARACTER, INTENT(IN) :: NAME(2)*24 + INTEGER, INTENT(IN) :: INPCI + INTEGER :: ILBL + CHARACTER, INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J - CHARACTER :: RECORD*15, CTIME*8, CDATE*8 + INTEGER :: I, J + CHARACTER :: RECORD*15, CTIME*8, CDATE*8 !----------------------------------------------- - I = INDEX(NAME(1),' ') - J = INDEX(NAME(2),' ') + I = INDEX(NAME(1),' ') + J = INDEX(NAME(2),' ') IF(ILBL == 0) THEN - IF (INPCI == 0) THEN + IF (INPCI == 0) THEN OPEN(UNIT=24,FILE=NAME(1)(1:I-1)//'.'//NAME(2)(1:J-1)//'.ct',FORM=& - 'FORMATTED', STATUS='UNKNOWN',POSITION='asis') - ELSE + 'FORMATTED', STATUS='UNKNOWN',POSITION='asis') + ELSE OPEN(UNIT=24,FILE=NAME(1)(1:I-1)//'.'//NAME(2)(1:J-1)//'.t',FORM=& - 'FORMATTED',STATUS='UNKNOWN',POSITION='asis') - ENDIF + 'FORMATTED',STATUS='UNKNOWN',POSITION='asis') + ENDIF ELSE IF(ILBL == 1) THEN IF(IOPEN_STATUS1.EQ.0 .AND. IOPEN_STATUS2 .EQ.0) THEN IF (INPCI == 0) THEN @@ -167,7 +167,7 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) ! WRITE (24,*) ! CALL ENGOUT1 (EAVFF,EVALFF,IATJPOFF,IASPARFF,IVECFF,NVECFF,3,2) ! - RETURN + RETURN ! 300 FORMAT ('The atomic number is ',1F14.10,';') 301 FORMAT (' c =',1P,1D19.12,' Bohr radii,' & @@ -191,6 +191,6 @@ SUBROUTINE STRSUM(NAME, INPCI, ILBL) 'gamma',19X,'P(2)',18X,'Q(2)',10X,'MTP') 310 FORMAT (3X,1I2,1A2,1X,1P,5(3X,1D19.12),3X,1I3) - RETURN + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rtransition90_mpi/strsum_I.f90 b/src/appl/rtransition90_mpi/strsum_I.f90 index 9ed6dd6cb..428363855 100644 --- a/src/appl/rtransition90_mpi/strsum_I.f90 +++ b/src/appl/rtransition90_mpi/strsum_I.f90 @@ -1,13 +1,13 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE strsum (NAME, INPCI,ILBL) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: INPCI + SUBROUTINE strsum (NAME, INPCI,ILBL) + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: INPCI INTEGER :: ILBL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/testmix.f90 b/src/appl/rtransition90_mpi/testmix.f90 index cdb788f24..f39dcb544 100644 --- a/src/appl/rtransition90_mpi/testmix.f90 +++ b/src/appl/rtransition90_mpi/testmix.f90 @@ -1,55 +1,55 @@ !*********************************************************************** ! * - SUBROUTINE TESTMIX + SUBROUTINE TESTMIX ! * ! This routine checks the mixing coefficients * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:35:54 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE biorb_C USE def_C USE eigv_C USE prnt_C USE syma_C - + IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! ! - - WRITE (*, *) ' ****************' - WRITE (*, *) ' Entering testmix' - WRITE (*, *) ' ****************' - WRITE (*, *) - WRITE (*, *) 'Initial state' - WRITE (*, *) 'EVALII', (EAVII + EVALII(I),I=1,NVECII) + + WRITE (*, *) ' ****************' + WRITE (*, *) ' Entering testmix' + WRITE (*, *) ' ****************' + WRITE (*, *) + WRITE (*, *) 'Initial state' + WRITE (*, *) 'EVALII', (EAVII + EVALII(I),I=1,NVECII) WRITE (*, *) 'NELECII,NCFII,NWII,NVECMXII', NELECII, NCFII, NWII, NVECMXII - WRITE (*, *) NVECII - WRITE (*, *) (IVECII(I),I=1,NVECII) - WRITE (*, *) (IATJPOII(I),IASPARII(I),I=1,NVECII) - WRITE (*, *) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) - - WRITE (*, *) 'Final state' - WRITE (*, *) 'EVALFF', (EAVFF + EVALFF(I),I=1,NVECFF) + WRITE (*, *) NVECII + WRITE (*, *) (IVECII(I),I=1,NVECII) + WRITE (*, *) (IATJPOII(I),IASPARII(I),I=1,NVECII) + WRITE (*, *) ((EVECII(I + (J - 1)*NCFII),I=1,NCFII),J=1,NVECII) + + WRITE (*, *) 'Final state' + WRITE (*, *) 'EVALFF', (EAVFF + EVALFF(I),I=1,NVECFF) WRITE (*, *) 'NELECFF,NCFFF,NWFF,NVECMXFF', NELECFF, NCFFF, NWFF, NVECMXFF - WRITE (*, *) NVECFF - WRITE (*, *) (IVECFF(I),I=1,NVECFF) - WRITE (*, *) (IATJPOFF(I),IASPARFF(I),I=1,NVECFF) - WRITE (*, *) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) - WRITE (*, *) - WRITE (*, *) ' ***************' - WRITE (*, *) ' Leaving testmix' - WRITE (*, *) ' ***************' - - RETURN - END SUBROUTINE TESTMIX + WRITE (*, *) NVECFF + WRITE (*, *) (IVECFF(I),I=1,NVECFF) + WRITE (*, *) (IATJPOFF(I),IASPARFF(I),I=1,NVECFF) + WRITE (*, *) ((EVECFF(I + (J - 1)*NCFFF),I=1,NCFFF),J=1,NVECFF) + WRITE (*, *) + WRITE (*, *) ' ***************' + WRITE (*, *) ' Leaving testmix' + WRITE (*, *) ' ***************' + + RETURN + END SUBROUTINE TESTMIX diff --git a/src/appl/rtransition90_mpi/testmix_I.f90 b/src/appl/rtransition90_mpi/testmix_I.f90 index 940c89b0c..ab709c532 100644 --- a/src/appl/rtransition90_mpi/testmix_I.f90 +++ b/src/appl/rtransition90_mpi/testmix_I.f90 @@ -1,9 +1,9 @@ - MODULE testmix_I + MODULE testmix_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE testmix - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE testmix + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rtransition90_mpi/trsortmpi.f90 b/src/appl/rtransition90_mpi/trsortmpi.f90 index f44ef72a5..4f24543de 100644 --- a/src/appl/rtransition90_mpi/trsortmpi.f90 +++ b/src/appl/rtransition90_mpi/trsortmpi.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) + SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! * ! Routine to sort angular coefficients into list based on integral * ! labels rather than CSF. A tree sort is used. To save space, the * @@ -15,13 +15,13 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! Last update: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB USE memory_man USE default_C @@ -31,24 +31,24 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alclla_I - USE alcnma_I + USE alclla_I + USE alcnma_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NFILE2 - INTEGER :: JKP - INTEGER, INTENT(IN) :: IBLKI - INTEGER, INTENT(IN) :: IBLKF - LOGICAL, INTENT(IN) :: LPRINT - CHARACTER, INTENT(IN) :: NAME(2)*24 + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NFILE2 + INTEGER :: JKP + INTEGER, INTENT(IN) :: IBLKI + INTEGER, INTENT(IN) :: IBLKF + LOGICAL, INTENT(IN) :: LPRINT + CHARACTER, INTENT(IN) :: NAME(2)*24 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NCA = 65536 - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: NCA = 65536 + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -56,10 +56,10 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ILAST, IBLINT, IPTCSF, LBLINT, JLABL, ISLDR, ISLDR1 REAL(DOUBLE), DIMENSION(:), pointer :: XSLDR, XL INTEGER :: NMCP, NINT, NLABEL, LLDIM, NMDIM, IR, IS, NI, I, M, J, & - ICOUNT, JLAB, K, L, IMCP, J1, J2, MLR, MUP, INTS, IA, IB + ICOUNT, JLAB, K, L, IMCP, J1, J2, MLR, MUP, INTS, IA, IB REAL(DOUBLE) :: X - LOGICAL :: FIRST - CHARACTER(LEN=2), DIMENSION(-9:9) :: S + LOGICAL :: FIRST + CHARACTER(LEN=2), DIMENSION(-9:9) :: S !----------------------------------------------- ! ! @@ -69,300 +69,300 @@ SUBROUTINE TRSORT(NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) ! POINTER (PIPTR,IPTR(1)) ! ! - S((-9)) = '-9' - S((-8)) = '-8' - S((-7)) = '-7' - S((-6)) = '-6' - S((-5)) = '-5' - S((-4)) = '-4' - S((-3)) = '-3' - S((-2)) = '-2' - S((-1)) = '-1' - S(0) = '+0' - S(1) = '+1' - S(2) = '+2' - S(3) = '+3' - S(4) = '+4' - S(5) = '+5' - S(6) = '+6' - S(7) = '+7' - S(8) = '+8' - S(9) = '+9' + S((-9)) = '-9' + S((-8)) = '-8' + S((-7)) = '-7' + S((-6)) = '-6' + S((-5)) = '-5' + S((-4)) = '-4' + S((-3)) = '-3' + S((-2)) = '-2' + S((-1)) = '-1' + S(0) = '+0' + S(1) = '+1' + S(2) = '+2' + S(3) = '+3' + S(4) = '+4' + S(5) = '+5' + S(6) = '+6' + S(7) = '+7' + S(8) = '+8' + S(9) = '+9' ! ! Position file at beginning of list of integrals ! - REWIND (NFILE) + REWIND (NFILE) ! ! Initialize ! - FIRST = .TRUE. - NMCP = 0 - NINT = 0 + FIRST = .TRUE. + NMCP = 0 + NINT = 0 ! ! Initial allocation of storage to local arrays ! - NLABEL = 1 - CALL ALLOC (JLABL, NLABEL, 'JLABL', 'TRSORT') - CALL ALLOC (XL, NLABEL, 'XL', 'TRSORT') + NLABEL = 1 + CALL ALLOC (JLABL, NLABEL, 'JLABL', 'TRSORT') + CALL ALLOC (XL, NLABEL, 'XL', 'TRSORT') ! CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, 1) - CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 1) + LLDIM, 1) + CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 1) ! ! Now the rest of the elements ! - 1 CONTINUE - READ (NFILE, END=12) IR, IS, NI - IF (NI > NLABEL) THEN - CALL RALLOC (JLABL, NI, 'JLABL', 'TRSORT') - CALL RALLOC (XL, NI, 'XL', 'TRSORT') - NLABEL = NI - ENDIF - READ (NFILE, END=99, ERR=99) (JLABL(I),XL(I),I=1,NI) - IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 1 + 1 CONTINUE + READ (NFILE, END=12) IR, IS, NI + IF (NI > NLABEL) THEN + CALL RALLOC (JLABL, NI, 'JLABL', 'TRSORT') + CALL RALLOC (XL, NI, 'XL', 'TRSORT') + NLABEL = NI + ENDIF + READ (NFILE, END=99, ERR=99) (JLABL(I),XL(I),I=1,NI) + IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 1 ! - IF (FIRST) THEN + IF (FIRST) THEN ! ! List is empty ! - M = 0 - J = 0 + M = 0 + J = 0 ! ! Set up list pointers and insert first element ! - ICOUNT = 0 - 3 CONTINUE - ICOUNT = ICOUNT + 1 - IF (ICOUNT > NI) GO TO 1 - IF (JLABL(ICOUNT) == 0) GO TO 3 - ILAB(1) = JLABL(ICOUNT) + ICOUNT = 0 + 3 CONTINUE + ICOUNT = ICOUNT + 1 + IF (ICOUNT > NI) GO TO 1 + IF (JLABL(ICOUNT) == 0) GO TO 3 + ILAB(1) = JLABL(ICOUNT) ! - IRIGHT(1) = 0 - ILEFT(1) = 0 - IBEG(1) = 1 - IPTR(1) = 0 - ILAST(1) = 0 + IRIGHT(1) = 0 + ILEFT(1) = 0 + IBEG(1) = 1 + IPTR(1) = 0 + ILAST(1) = 0 ! - M = 1 - J = 1 + M = 1 + J = 1 ! - FIRST = .FALSE. + FIRST = .FALSE. ! - ELSE + ELSE ! - ICOUNT = 0 + ICOUNT = 0 ! - ENDIF + ENDIF ! ! Sort integral list using tree sort ! ! Take next nonzero element ! - 4 CONTINUE - ICOUNT = ICOUNT + 1 - IF (ICOUNT > NI) GO TO 1 - JLAB = JLABL(ICOUNT) - IF (JLAB == 0) GO TO 4 - X = XL(ICOUNT) + 4 CONTINUE + ICOUNT = ICOUNT + 1 + IF (ICOUNT > NI) GO TO 1 + JLAB = JLABL(ICOUNT) + IF (JLAB == 0) GO TO 4 + X = XL(ICOUNT) ! - M = M + 1 - IF (M > NMDIM) CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 2) - I = 1 + M = M + 1 + IF (M > NMDIM) CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 2) + I = 1 ! ! Search for place in tree ! - 5 CONTINUE - IF (JLAB - ILAB(I) > 0) GO TO 8 - IF (JLAB - ILAB(I) == 0) GO TO 10 - K = IRIGHT(I) - IF (K /= 0) GO TO 7 - J = J + 1 + 5 CONTINUE + IF (JLAB - ILAB(I) > 0) GO TO 8 + IF (JLAB - ILAB(I) == 0) GO TO 10 + K = IRIGHT(I) + IF (K /= 0) GO TO 7 + J = J + 1 IF (J > LLDIM) CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, & - IRIGHT, LBLINT, LLDIM, 2) - IRIGHT(I) = J - GO TO 9 - 7 CONTINUE - I = K - GO TO 5 - 8 CONTINUE - K = ILEFT(I) - IF (K /= 0) GO TO 7 - J = J + 1 + IRIGHT, LBLINT, LLDIM, 2) + IRIGHT(I) = J + GO TO 9 + 7 CONTINUE + I = K + GO TO 5 + 8 CONTINUE + K = ILEFT(I) + IF (K /= 0) GO TO 7 + J = J + 1 IF (J > LLDIM) CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, & - IRIGHT, LBLINT, LLDIM, 2) - ILEFT(I) = J + IRIGHT, LBLINT, LLDIM, 2) + ILEFT(I) = J ! ! When found, update list. ! - 9 CONTINUE - ILAST(J) = I - IRIGHT(J) = 0 - ILEFT(J) = 0 - IBEG(J) = M - ILAB(J) = JLAB - IPTR(M) = 0 - GO TO 4 - 10 CONTINUE - K = IBEG(I) - L = K - K = IPTR(L) - DO WHILE(K /= 0) - L = K - K = IPTR(L) - END DO - IPTR(L) = M - IPTR(M) = 0 - GO TO 4 + 9 CONTINUE + ILAST(J) = I + IRIGHT(J) = 0 + ILEFT(J) = 0 + IBEG(J) = M + ILAB(J) = JLAB + IPTR(M) = 0 + GO TO 4 + 10 CONTINUE + K = IBEG(I) + L = K + K = IPTR(L) + DO WHILE(K /= 0) + L = K + K = IPTR(L) + END DO + IPTR(L) = M + IPTR(M) = 0 + GO TO 4 ! ! The end of the CSF-based file has been reached ! - 12 CONTINUE - IF (.NOT.(FIRST .OR. M==0)) THEN + 12 CONTINUE + IF (.NOT.(FIRST .OR. M==0)) THEN ! ! Sort is complete. Unpack list ! - NMCP = M - NINT = J - L = 0 - M = 0 - I = 1 + NMCP = M + NINT = J + L = 0 + M = 0 + I = 1 ! ! Search for smallest element ! - 13 CONTINUE - K = IRIGHT(I) - DO WHILE(K /= 0) - I = K - K = IRIGHT(I) - END DO + 13 CONTINUE + K = IRIGHT(I) + DO WHILE(K /= 0) + I = K + K = IRIGHT(I) + END DO ! ! Insert in sorted list ! - 14 CONTINUE - IF (ILAB(I) == 0) GO TO 16 - L = L + 1 - LBLINT(L) = ILAB(I) - K = IBEG(I) + 14 CONTINUE + IF (ILAB(I) == 0) GO TO 16 + L = L + 1 + LBLINT(L) = ILAB(I) + K = IBEG(I) ! ! Copy list of pointers to CSF/coefficients into new list ! - M = M + 1 - ISLDR(M) = K - K = IPTR(K) - DO WHILE(K /= 0) - M = M + 1 - ISLDR(M) = K - K = IPTR(K) - END DO - IPTCSF(L) = M - ILAB(I) = 0 + M = M + 1 + ISLDR(M) = K + K = IPTR(K) + DO WHILE(K /= 0) + M = M + 1 + ISLDR(M) = K + K = IPTR(K) + END DO + IPTCSF(L) = M + ILAB(I) = 0 ! ! Next smallest element is on left of last element ! - K = ILEFT(I) - IF (K == 0) GO TO 16 - I = K - GO TO 13 + K = ILEFT(I) + IF (K == 0) GO TO 16 + I = K + GO TO 13 ! ! If no element on left, next smallest is previous element ! - 16 CONTINUE - I = ILAST(I) - IF (I /= 0) GO TO 14 + 16 CONTINUE + I = ILAST(I) + IF (I /= 0) GO TO 14 ! ! List is unpacked. Invert CSF/coefficient pointer list to give ! position list for CSF/coefficients as they are read in ! - DO I = 1, NMCP - K = ISLDR(I) - IPTR(K) = I - END DO + DO I = 1, NMCP + K = ISLDR(I) + IPTR(K) = I + END DO ! ! Now read CSF pairs and coefficients into correct positions in ! sorted list ! - IMCP = 0 - REWIND (NFILE) - 18 CONTINUE - READ (NFILE, END=20) IR, IS, NI - IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 18 - READ (NFILE) (JLABL(I),XL(I),I=1,NI) - DO I = 1, NI - IF (JLABL(I) == 0) CYCLE - IMCP = IMCP + 1 - K = IPTR(IMCP) - ISLDR(K) = IR - ISLDR1(K) = IS + IMCP = 0 + REWIND (NFILE) + 18 CONTINUE + READ (NFILE, END=20) IR, IS, NI + IF (IR==0 .OR. IS==0 .OR. NI==0) GO TO 18 + READ (NFILE) (JLABL(I),XL(I),I=1,NI) + DO I = 1, NI + IF (JLABL(I) == 0) CYCLE + IMCP = IMCP + 1 + K = IPTR(IMCP) + ISLDR(K) = IR + ISLDR1(K) = IS ! ISLDR(K) = IR*NCA+IS - XSLDR(K) = XL(I) - END DO - GO TO 18 + XSLDR(K) = XL(I) + END DO + GO TO 18 ! ! The integral-based list is completely known ! - ENDIF - 20 CONTINUE - REWIND (NFILE) + ENDIF + 20 CONTINUE + REWIND (NFILE) ! ! If first set of data open the file and print ! some data to later be able to identify the file ! - IF (IBLKI==1 .AND. IBLKF==1) THEN - J1 = INDEX(NAME(1),' ') - J2 = INDEX(NAME(2),' ') + IF (IBLKI==1 .AND. IBLKF==1) THEN + J1 = INDEX(NAME(1),' ') + J2 = INDEX(NAME(2),' ') OPEN(UNIT=NFILE2,FILE=NAME(1)(1:J1-1)//'.'//NAME(2)(1:J2-1)//'.'//S(& KP(JKP))//'T', STATUS='UNKNOWN', FORM='UNFORMATTED', POSITION=& - 'asis') - ENDIF + 'asis') + ENDIF WRITE (NFILE2) IBLKI,IBLKF,NW,NKP,nprocs,myid - WRITE (NFILE2) NINT - IF (NMCP /= 0) THEN - IF (LPRINT) WRITE (99, 301) - MLR = 1 - DO I = 1, NINT - MUP = IPTCSF(I) - INTS = MUP - MLR + 1 - WRITE (NFILE2) LBLINT(I), INTS - IF (LPRINT) THEN - IA = LBLINT(I)/KEY - IB = MOD(LBLINT(I),KEY) - WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB) - ENDIF - WRITE (NFILE2) (ISLDR(M),ISLDR1(M),XSLDR(M),M=MLR,MUP) - IF (LPRINT) THEN - DO M = MLR, MUP + WRITE (NFILE2) NINT + IF (NMCP /= 0) THEN + IF (LPRINT) WRITE (99, 301) + MLR = 1 + DO I = 1, NINT + MUP = IPTCSF(I) + INTS = MUP - MLR + 1 + WRITE (NFILE2) LBLINT(I), INTS + IF (LPRINT) THEN + IA = LBLINT(I)/KEY + IB = MOD(LBLINT(I),KEY) + WRITE (99, 302) NP(IA), NH(IA), NP(IB), NH(IB) + ENDIF + WRITE (NFILE2) (ISLDR(M),ISLDR1(M),XSLDR(M),M=MLR,MUP) + IF (LPRINT) THEN + DO M = MLR, MUP ! IS = MOD (ISLDR(M),NCA) - IS = ISLDR1(M) + IS = ISLDR1(M) ! IR = ISLDR(M)/NCA - IR = ISLDR(M) - WRITE (99, 303) IR, IS, XSLDR(M) - END DO - ENDIF - MLR = MUP + 1 - END DO + IR = ISLDR(M) + WRITE (99, 303) IR, IS, XSLDR(M) + END DO + ENDIF + MLR = MUP + 1 + END DO ! - ENDIF + ENDIF ! ! Deallocate storage for local arrays ! - CALL DALLOC (JLABL, 'JLABJ', 'TRSORT') - CALL DALLOC (XL, 'XL', 'TRSORT') + CALL DALLOC (JLABL, 'JLABJ', 'TRSORT') + CALL DALLOC (XL, 'XL', 'TRSORT') CALL ALCLLA (IBEG, ILAB, ILAST, ILEFT, IPTCSF, IRIGHT, LBLINT, & - LLDIM, 3) - CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 3) + LLDIM, 3) + CALL ALCNMA (IPTR, ISLDR, ISLDR1, XSLDR, NMDIM, 3) ! - RETURN + RETURN ! ! Error handling ! - 99 CONTINUE - WRITE (6, *) 'TRSORT: Error reading CSF-based file.' - STOP + 99 CONTINUE + WRITE (6, *) 'TRSORT: Error reading CSF-based file.' + STOP ! 301 FORMAT(/,/,' k'/,' d (rs) Coefficients:'/,' ab'/,/,/,& - ' a b r s Coefficient'/) - 302 FORMAT(2(2X,I2,A2)) - 303 FORMAT(14X,1I6,2X,1I6,2X,1P,1D22.15) - RETURN + ' a b r s Coefficient'/) + 302 FORMAT(2(2X,I2,A2)) + 303 FORMAT(14X,1I6,2X,1I6,2X,1P,1D22.15) + RETURN ! - END SUBROUTINE TRSORT + END SUBROUTINE TRSORT diff --git a/src/appl/rtransition90_mpi/trsortmpi_I.f90 b/src/appl/rtransition90_mpi/trsortmpi_I.f90 index 2e38bbbfd..25f4bf7a9 100644 --- a/src/appl/rtransition90_mpi/trsortmpi_I.f90 +++ b/src/appl/rtransition90_mpi/trsortmpi_I.f90 @@ -1,16 +1,16 @@ - MODULE trsort_I + MODULE trsort_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:53:13 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE trsort (NAME, NFILE, NFILE2, LPRINT, JKP, IBLKI, IBLKF) - CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: NFILE2 - LOGICAL, INTENT(IN) :: LPRINT - INTEGER :: JKP - INTEGER, INTENT(IN) :: IBLKI - INTEGER, INTENT(IN) :: IBLKF - END SUBROUTINE - END INTERFACE - END MODULE + CHARACTER (LEN = 24), DIMENSION(2), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: NFILE2 + LOGICAL, INTENT(IN) :: LPRINT + INTEGER :: JKP + INTEGER, INTENT(IN) :: IBLKI + INTEGER, INTENT(IN) :: IBLKF + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/Makefile b/src/appl/rwfnestimate90/Makefile old mode 100755 new mode 100644 index ffe823f44..996894192 --- a/src/appl/rwfnestimate90/Makefile +++ b/src/appl/rwfnestimate90/Makefile @@ -35,4 +35,3 @@ $(EXE): ${APP_IOBJ} $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/rwfnestimate90/erwf.f90 b/src/appl/rwfnestimate90/erwf.f90 index aeac65a09..8ce49e1bf 100644 --- a/src/appl/rwfnestimate90/erwf.f90 +++ b/src/appl/rwfnestimate90/erwf.f90 @@ -24,7 +24,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM ERWF + PROGRAM ERWF ! * ! Entry routine for RCI92. Controls the entire computation. * ! * @@ -37,37 +37,37 @@ PROGRAM ERWF ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEFAULT_C - USE CONS_C - USE IOUNIT_C + USE vast_kind_param, ONLY: DOUBLE + USE DEFAULT_C + USE CONS_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setcsh_I - USE screenpar_I - USE getinf_I - USE strsum_I - USE genrwf_I - USE orthsc_I - USE wrtrwf_I + USE getyn_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setcsh_I + USE screenpar_I + USE getinf_I + USE strsum_I + USE genrwf_I + USE orthsc_I + USE wrtrwf_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NCORE - LOGICAL :: YES + INTEGER :: NCORE + LOGICAL :: YES !----------------------------------------------- - + ! Startup message ! WRITE (ISTDE, *) 'RWFNESTIMATE' @@ -78,63 +78,63 @@ PROGRAM ERWF ! - WRITE (ISTDE, *) 'Default settings ?' - YES = GETYN() - IF (YES) THEN - NDEF = 0 - ELSE - NDEF = 1 - ENDIF - + WRITE (ISTDE, *) 'Default settings ?' + YES = GETYN() + IF (YES) THEN + NDEF = 0 + ELSE + NDEF = 1 + ENDIF + ! ! Determine if there is to be any debug printout; this will be ! made on the .dbg file ! - CALL SETDBG + CALL SETDBG ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Open the .sum file ! - IF (NDEF /= 0) CALL SETSUM + IF (NDEF /= 0) CALL SETSUM ! ! Open, check, load data from, and close the .csl file ! - CALL SETCSH (21, 'rcsf.inp', NCORE) + CALL SETCSH (21, 'rcsf.inp', NCORE) ! ! Hydrogenic screen parameters for all orbitals ! - CALL SCREENPAR (NCORE) + CALL SCREENPAR (NCORE) ! ! Determine other relevant information ! - CALL GETINF + CALL GETINF ! ! Write the first part of the .sum file ! - IF (NDEF /= 0) CALL STRSUM + IF (NDEF /= 0) CALL STRSUM ! ! Generate the subshell radial wavefunctions ! - CALL GENRWF + CALL GENRWF ! ! Orthogonalize the radial orbitals ! - CALL ORTHSC + CALL ORTHSC ! ! Write the subshell radial wavefunctions out ! - CALL WRTRWF + CALL WRTRWF ! ! Print completion message ! - WRITE (ISTDE, *) 'RWFNESTIMATE: Execution complete.' + WRITE (ISTDE, *) 'RWFNESTIMATE: Execution complete.' ! - STOP - END PROGRAM ERWF + STOP + END PROGRAM ERWF diff --git a/src/appl/rwfnestimate90/frmhyd.f90 b/src/appl/rwfnestimate90/frmhyd.f90 index 39dfd8a52..8eb8594eb 100644 --- a/src/appl/rwfnestimate90/frmhyd.f90 +++ b/src/appl/rwfnestimate90/frmhyd.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE FRMHYD(INDEX, NSUBS, MODIFY) + SUBROUTINE FRMHYD(INDEX, NSUBS, MODIFY) ! * ! This subroutine is used to produce estimates of the wave * ! functions from the hydrogenic approximation. The screening cons- * @@ -14,64 +14,64 @@ SUBROUTINE FRMHYD(INDEX, NSUBS, MODIFY) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE LEFT_C - USE ORB_C, ONLY: E, NP, NAK, NH + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE LEFT_C + USE ORB_C, ONLY: E, NP, NAK, NH USE WAVE_C, ONLY: PF, QF, PZ, MF - USE WHFROM_C, ONLY: SOURCE - USE HYDPAR_C, ONLY: SIGMA - USE IOUNIT_C - USE DEFAULT_C + USE WHFROM_C, ONLY: SOURCE + USE HYDPAR_C, ONLY: SIGMA + USE IOUNIT_C + USE DEFAULT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dcbsrw_I + USE dcbsrw_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NSUBS - LOGICAL , INTENT(IN) :: MODIFY - INTEGER , INTENT(IN) :: INDEX(NNNW) + INTEGER , INTENT(IN) :: NSUBS + LOGICAL , INTENT(IN) :: MODIFY + INTEGER , INTENT(IN) :: INDEX(NNNW) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - !INTEGER, PARAMETER :: NNNP = 590 - INTEGER, PARAMETER :: NNN1 = NNNP + 10 + !INTEGER, PARAMETER :: NNNP = 590 + INTEGER, PARAMETER :: NNN1 = NNNP + 10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, LOC - REAL(DOUBLE) :: ZEFF - LOGICAL :: YES, GETYN + INTEGER :: J, LOC + REAL(DOUBLE) :: ZEFF + LOGICAL :: YES, GETYN !----------------------------------------------- ! ! - WRITE (ISTDE, *) - WRITE (ISTDE, *) '***** Screening parameters ******' - DO J = 1, NSUBS - LOC = INDEX(J) - IF (SET(LOC)) CYCLE - - WRITE (ISTDE, '(I2,A2,F10.2)') NP(LOC), NH(LOC), SIGMA(LOC) - IF (MODIFY) THEN - WRITE (ISTDE, *) 'Input new value >' - READ (5, *) SIGMA(LOC) - ENDIF - - ZEFF = Z - SIGMA(LOC) - + WRITE (ISTDE, *) + WRITE (ISTDE, *) '***** Screening parameters ******' + DO J = 1, NSUBS + LOC = INDEX(J) + IF (SET(LOC)) CYCLE + + WRITE (ISTDE, '(I2,A2,F10.2)') NP(LOC), NH(LOC), SIGMA(LOC) + IF (MODIFY) THEN + WRITE (ISTDE, *) 'Input new value >' + READ (5, *) SIGMA(LOC) + ENDIF + + ZEFF = Z - SIGMA(LOC) + ! ...Calculate radial wavefunctions CALL DCBSRW (NP(LOC), NAK(LOC), ZEFF, E(LOC), PZ(LOC), PF(:,LOC), & - QF(:,LOC), MF(LOC)) - SET(LOC) = .TRUE. + QF(:,LOC), MF(LOC)) + SET(LOC) = .TRUE. !SOURCE(LOC) = 'Screened hydrogenic estimate' - SOURCE(LOC) = 'Hyd' - END DO - RETURN - END SUBROUTINE FRMHYD + SOURCE(LOC) = 'Hyd' + END DO + RETURN + END SUBROUTINE FRMHYD diff --git a/src/appl/rwfnestimate90/frmhyd_I.f90 b/src/appl/rwfnestimate90/frmhyd_I.f90 index 5c93dc730..98439d6c0 100644 --- a/src/appl/rwfnestimate90/frmhyd_I.f90 +++ b/src/appl/rwfnestimate90/frmhyd_I.f90 @@ -1,12 +1,12 @@ - MODULE frmhyd_I + MODULE frmhyd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE frmhyd (INDEX, NSUBS, MODIFY) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX - INTEGER, INTENT(IN) :: NSUBS - LOGICAL, INTENT(IN) :: MODIFY - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE frmhyd (INDEX, NSUBS, MODIFY) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX + INTEGER, INTENT(IN) :: NSUBS + LOGICAL, INTENT(IN) :: MODIFY + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/frmrwf.f90 b/src/appl/rwfnestimate90/frmrwf.f90 index 266491df9..95f57f17b 100644 --- a/src/appl/rwfnestimate90/frmrwf.f90 +++ b/src/appl/rwfnestimate90/frmrwf.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE FRMRWF(INDEX, NSUBS, FILNAM) + SUBROUTINE FRMRWF(INDEX, NSUBS, FILNAM) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -12,107 +12,107 @@ SUBROUTINE FRMRWF(INDEX, NSUBS, FILNAM) ! Written by Farid A. Parpia Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE DEBUG_C - USE GRID_C - USE LEFT_C - USE ORB_C, ONLY: E, NP, NAK, NH - USE WAVE_C, ONLY: PZ - USE WHFROM_C, ONLY: SOURCE - USE IOUNIT_C + USE DEBUG_C + USE GRID_C + USE LEFT_C + USE ORB_C, ONLY: E, NP, NAK, NH + USE WAVE_C, ONLY: PZ + USE WHFROM_C, ONLY: SOURCE + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE intrpq_I + USE openfl_I + USE intrpq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NSUBS - CHARACTER :: FILNAM*(*) - INTEGER , INTENT(IN) :: INDEX(NNNW) + INTEGER , INTENT(IN) :: NSUBS + CHARACTER :: FILNAM*(*) + INTEGER , INTENT(IN) :: INDEX(NNNW) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS, NPY, NAKY, MY, J, LOC, I, LENTH - REAL(DOUBLE) :: EY, DNORM + INTEGER :: IERR, IOS, NPY, NAKY, MY, J, LOC, I, LENTH + REAL(DOUBLE) :: EY, DNORM REAL(DOUBLE), DIMENSION(:), pointer :: PA, QA, RA - LOGICAL :: FOUND - CHARACTER :: G92RWF*6 + LOGICAL :: FOUND + CHARACTER :: G92RWF*6 !----------------------------------------------- ! ! - + !FORM = 'UNFORMATTED' !STATUS = 'OLD' - - CALL OPENFL (23, FILNAM, 'UNFORMATTED', 'OLD', IERR) - IF (IERR == 1) THEN + + CALL OPENFL (23, FILNAM, 'UNFORMATTED', 'OLD', IERR) + IF (IERR == 1) THEN WRITE (ISTDE, *) 'Error openning file "', FILNAM(1:LEN_TRIM(FILNAM)), & - '"' - CLOSE(23) - STOP - ENDIF + '"' + CLOSE(23) + STOP + ENDIF ! ! Check the file; if not as expected, try again ! - READ (23, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (ISTDE, *) 'This is not a Radial WaveFunction File;' - CLOSE(23) - STOP - ENDIF + READ (23, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (ISTDE, *) 'This is not a Radial WaveFunction File;' + CLOSE(23) + STOP + ENDIF ! ! Read orbital information from Read Orbitals File; write summary ! to .dbg file if option set ! - IF (LDBPR(3)) WRITE (99, 300) - 2 CONTINUE - FOUND = .FALSE. - READ (23, IOSTAT=IOS) NPY, NAKY, EY, MY - IF (IOS == 0) THEN - DO J = 1, NSUBS - LOC = INDEX(J) + IF (LDBPR(3)) WRITE (99, 300) + 2 CONTINUE + FOUND = .FALSE. + READ (23, IOSTAT=IOS) NPY, NAKY, EY, MY + IF (IOS == 0) THEN + DO J = 1, NSUBS + LOC = INDEX(J) IF (.NOT.(.NOT.SET(LOC) .AND. NP(LOC)==NPY .AND. NAK(LOC)==NAKY)) & - CYCLE - FOUND = .TRUE. - E(LOC) = EY - CALL ALLOC (PA, MY, 'PA', 'FRMFRW') - CALL ALLOC (QA, MY, 'QA', 'FRMFRW') - CALL ALLOC (RA, MY, 'RA', 'FRMFRW') - READ (23) PZ(LOC), (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (23) (RA(I),I=1,MY) - CALL INTRPQ (PA, QA, MY, RA, LOC, DNORM) - IF (LDBPR(3)) WRITE (99, 301) NP(LOC), NH(LOC), E(LOC), DNORM - CALL DALLOC (PA, 'PA', 'FRMFRW') - CALL DALLOC (QA, 'QA', 'FRMFRW') - CALL DALLOC (RA, 'RA', 'FRMFRW') - LENTH = LEN_TRIM(FILNAM) - SET(LOC) = .TRUE. - SOURCE(LOC) = FILNAM(1:3) - GO TO 2 - END DO - IF (.NOT.FOUND) THEN - READ (23) - READ (23) - GO TO 2 - ENDIF - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + CYCLE + FOUND = .TRUE. + E(LOC) = EY + CALL ALLOC (PA, MY, 'PA', 'FRMFRW') + CALL ALLOC (QA, MY, 'QA', 'FRMFRW') + CALL ALLOC (RA, MY, 'RA', 'FRMFRW') + READ (23) PZ(LOC), (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (23) (RA(I),I=1,MY) + CALL INTRPQ (PA, QA, MY, RA, LOC, DNORM) + IF (LDBPR(3)) WRITE (99, 301) NP(LOC), NH(LOC), E(LOC), DNORM + CALL DALLOC (PA, 'PA', 'FRMFRW') + CALL DALLOC (QA, 'QA', 'FRMFRW') + CALL DALLOC (RA, 'RA', 'FRMFRW') + LENTH = LEN_TRIM(FILNAM) + SET(LOC) = .TRUE. + SOURCE(LOC) = FILNAM(1:3) + GO TO 2 + END DO + IF (.NOT.FOUND) THEN + READ (23) + READ (23) + GO TO 2 + ENDIF + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! - CLOSE(23) + CLOSE(23) ! - RETURN + RETURN ! 300 FORMAT(/,'From SUBROUTINE FRMRWF:'/,' Orbital',8X,'Eigenvalue',19X,'Norm'& - ) - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN + ) + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN ! - END SUBROUTINE FRMRWF + END SUBROUTINE FRMRWF diff --git a/src/appl/rwfnestimate90/frmrwf_I.f90 b/src/appl/rwfnestimate90/frmrwf_I.f90 index c1af6f2ae..82351fcc4 100644 --- a/src/appl/rwfnestimate90/frmrwf_I.f90 +++ b/src/appl/rwfnestimate90/frmrwf_I.f90 @@ -1,14 +1,14 @@ - MODULE frmrwf_I + MODULE frmrwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE frmrwf (INDEX, NSUBS, FILNAM) - INTEGER NNN1 - PARAMETER (NNN1 = 600) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX - INTEGER, INTENT(IN) :: NSUBS - CHARACTER (LEN = *), INTENT(IN) :: FILNAM - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE frmrwf (INDEX, NSUBS, FILNAM) + INTEGER NNN1 + PARAMETER (NNN1 = 600) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX + INTEGER, INTENT(IN) :: NSUBS + CHARACTER (LEN = *), INTENT(IN) :: FILNAM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/frmtfp.f90 b/src/appl/rwfnestimate90/frmtfp.f90 index 80814d522..6a53b00d6 100644 --- a/src/appl/rwfnestimate90/frmtfp.f90 +++ b/src/appl/rwfnestimate90/frmtfp.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE FRMTFP(INDEX, NSUBS) + SUBROUTINE FRMTFP(INDEX, NSUBS) ! * ! This subroutine is used to produce estimates of the wave * ! functions by use of the Thomas-Fermi approximation to the direct * @@ -15,72 +15,72 @@ SUBROUTINE FRMTFP(INDEX, NSUBS) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE LEFT_C, ONLY: SET - USE ORB_C, ONLY: NP, NH + USE vast_kind_param, ONLY: DOUBLE + USE LEFT_C, ONLY: SET + USE ORB_C, ONLY: NP, NH USE WAVE_C - USE WHFROM_C, ONLY: SOURCE + USE WHFROM_C, ONLY: SOURCE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE solvh_I + USE solvh_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NNNP = 590 + INTEGER, PARAMETER :: NNNP = 590 !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NSUBS - INTEGER , INTENT(IN) :: INDEX(NNNW) + INTEGER , INTENT(IN) :: NSUBS + INTEGER , INTENT(IN) :: INDEX(NNNW) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NNN1 = NNNP + 10 + INTEGER, PARAMETER :: NNN1 = NNNP + 10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, LOC - LOGICAL :: FAIL + INTEGER :: J, LOC + LOGICAL :: FAIL !----------------------------------------------- ! ! - DO J = 1, NSUBS + DO J = 1, NSUBS ! - LOC = INDEX(J) + LOC = INDEX(J) ! - IF (SET(LOC)) CYCLE + IF (SET(LOC)) CYCLE ! ! Estimate the leading coefficient of the series expansion for ! the orbital ! - PZ(LOC) = 10.0D00 + PZ(LOC) = 10.0D00 ! ! Calculate radial wavefunctions ! - CALL SOLVH (LOC, FAIL) + CALL SOLVH (LOC, FAIL) ! ! Message if SOLVH did not converge; reset SET(LOC) otherwise ! - IF (FAIL) THEN - WRITE (*, 300) NP(LOC), NH(LOC) - ELSE - SET(LOC) = .TRUE. + IF (FAIL) THEN + WRITE (*, 300) NP(LOC), NH(LOC) + ELSE + SET(LOC) = .TRUE. !SOURCE(LOC) = 'Thomas-Fermi estimate' - SOURCE(LOC) = 'T-F' - ENDIF + SOURCE(LOC) = 'T-F' + ENDIF ! - END DO + END DO ! - RETURN + RETURN ! 300 FORMAT(/,'TFWAVE: Unable to compute radial'/,/,' wavefunction for ',I2,A2& - ,' subshell;') - RETURN + ,' subshell;') + RETURN ! - END SUBROUTINE FRMTFP + END SUBROUTINE FRMTFP diff --git a/src/appl/rwfnestimate90/frmtfp_I.f90 b/src/appl/rwfnestimate90/frmtfp_I.f90 index d94654f1b..ab21eb30b 100644 --- a/src/appl/rwfnestimate90/frmtfp_I.f90 +++ b/src/appl/rwfnestimate90/frmtfp_I.f90 @@ -1,11 +1,11 @@ - MODULE frmtfp_I + MODULE frmtfp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE frmtfp (INDEX, NSUBS) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX - INTEGER, INTENT(IN) :: NSUBS - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE frmtfp (INDEX, NSUBS) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, DIMENSION(NNNW), INTENT(IN) :: INDEX + INTEGER, INTENT(IN) :: NSUBS + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/genrwf.f90 b/src/appl/rwfnestimate90/genrwf.f90 index 24fed9891..c1bc0cba7 100644 --- a/src/appl/rwfnestimate90/genrwf.f90 +++ b/src/appl/rwfnestimate90/genrwf.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE GENRWF + SUBROUTINE GENRWF ! * ! Controls the computation of the subshell radial wavefunctions. * ! * @@ -15,52 +15,52 @@ SUBROUTINE GENRWF ! for menu-driven and less questions ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE COUN_C - USE DEF_C, ONLY: Z, C, NNNP - USE DEFAULT_C + USE COUN_C + USE DEF_C, ONLY: Z, C, NNNP + USE DEFAULT_C USE GRID_C - USE LEFT_C, ONLY: SET - USE NPAR_C - USE ORB_C + USE LEFT_C, ONLY: SET + USE NPAR_C + USE ORB_C USE WAVE_C, ONLY: PF, QF - USE WHFROM_C, ONLY: SOURCE - USE IOUNIT_C + USE WHFROM_C, ONLY: SOURCE + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE tfpot_I - USE prtrem_I - USE getrsl_I - USE frmrwf_I - USE frmtfp_I - USE frmhyd_I - USE summry_I + USE getyn_I + USE tfpot_I + USE prtrem_I + USE getrsl_I + USE frmrwf_I + USE frmtfp_I + USE frmhyd_I + USE summry_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER , DIMENSION(NNNW) :: INDEX - INTEGER :: J, I, K, NRADIAL, NSUBS, LOC - REAL(DOUBLE) :: CON, FKK - LOGICAL :: ALL, YES, MODIFY=.FALSE., EXISTED - CHARACTER :: INFILE*128 + INTEGER , DIMENSION(NNNW) :: INDEX + INTEGER :: J, I, K, NRADIAL, NSUBS, LOC + REAL(DOUBLE) :: CON, FKK + LOGICAL :: ALL, YES, MODIFY=.FALSE., EXISTED + CHARACTER :: INFILE*128 !----------------------------------------------- ! ! Set the threshold for node counting ! - THRESH = 0.05 + THRESH = 0.05 ! ! Set up the Thomas-Fermi potential ! - CALL TFPOT + CALL TFPOT ! ! Allocate storage to the arrays that store the subshell ! radial wavefunction arrays; initialise these and all @@ -68,122 +68,122 @@ SUBROUTINE GENRWF ! CALL ALLOC (PF,NNNP,NW,'PF', 'GENRWF') CALL ALLOC (QF,NNNP,NW,'QF', 'GENRWF') - - CON = Z/C - CON = CON*CON - - DO J = 1, NW - SET(J) = .FALSE. - SOURCE(J) = ' ' - PF(:N,J) = 0.D0 - QF(:N,J) = 0.D0 - - K = ABS(NAK(J)) - IF (NPARM > 0) THEN - GAMA(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE + + CON = Z/C + CON = CON*CON + + DO J = 1, NW + SET(J) = .FALSE. + SOURCE(J) = ' ' + PF(:N,J) = 0.D0 + QF(:N,J) = 0.D0 + + K = ABS(NAK(J)) + IF (NPARM > 0) THEN + GAMA(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE WRITE (ISTDE, *) 'LODRWF: Imaginary gamma parameter ', 'for ', & - NP(J), NH(J), ' orbital;' + NP(J), NH(J), ' orbital;' WRITE (ISTDE, *) 'the point model for the nucleus ', & - 'is inappropriate for Z > ', C, '.' - STOP - ENDIF - ENDIF - END DO + 'is inappropriate for Z > ', C, '.' + STOP + ENDIF + ENDIF + END DO ! ! Write out the complete list of subshell radial wave functions ! - CALL PRTREM (ALL) + CALL PRTREM (ALL) ! ! Direct to read radial functions till finish ! - 123 CONTINUE - IF (.NOT.ALL) THEN - 234 CONTINUE - WRITE (ISTDE, *) + 123 CONTINUE + IF (.NOT.ALL) THEN + 234 CONTINUE + WRITE (ISTDE, *) WRITE (ISTDE, *) 'Read subshell radial wavefunctions. ', & - 'Choose one below' - WRITE (ISTDE, *) ' 1 -- GRASP92 File' - WRITE (ISTDE, *) ' 2 -- Thomas-Fermi' - WRITE (ISTDE, *) ' 3 -- Screened Hydrogenic' - - READ (ISTDI, *) NRADIAL - IF (NRADIAL<1 .OR. NRADIAL>3) THEN - WRITE (ISTDE, *) NRADIAL, 'is not a valid choice, redo' - GO TO 234 - ENDIF - - IF (NRADIAL == 1) THEN - 345 CONTINUE - WRITE (ISTDE, *) 'Enter the file name (Null then "rwfn.out")' - READ (ISTDI, '(A)') INFILE - IF (LEN_TRIM(INFILE) == 0) INFILE = 'rwfn.out' - - INQUIRE(FILE=INFILE, EXIST=EXISTED) - IF (.NOT.EXISTED) THEN + 'Choose one below' + WRITE (ISTDE, *) ' 1 -- GRASP92 File' + WRITE (ISTDE, *) ' 2 -- Thomas-Fermi' + WRITE (ISTDE, *) ' 3 -- Screened Hydrogenic' + + READ (ISTDI, *) NRADIAL + IF (NRADIAL<1 .OR. NRADIAL>3) THEN + WRITE (ISTDE, *) NRADIAL, 'is not a valid choice, redo' + GO TO 234 + ENDIF + + IF (NRADIAL == 1) THEN + 345 CONTINUE + WRITE (ISTDE, *) 'Enter the file name (Null then "rwfn.out")' + READ (ISTDI, '(A)') INFILE + IF (LEN_TRIM(INFILE) == 0) INFILE = 'rwfn.out' + + INQUIRE(FILE=INFILE, EXIST=EXISTED) + IF (.NOT.EXISTED) THEN WRITE (ISTDE, *) ' File "', INFILE(1:LEN_TRIM(INFILE)), & - '" does not exist, redo' - GO TO 345 - ENDIF - ENDIF - - WRITE (ISTDE, *) 'Enter the list of relativistic subshells:' + '" does not exist, redo' + GO TO 345 + ENDIF + ENDIF + + WRITE (ISTDE, *) 'Enter the list of relativistic subshells:' OPEN(UNIT=734, FILE='tmp_734', STATUS='NEW') - CALL GETRSL (INDEX, NSUBS) + CALL GETRSL (INDEX, NSUBS) CLOSE(734, STATUS='DELETE') - - IF (NRADIAL == 1) THEN - CALL FRMRWF (INDEX, NSUBS, INFILE) - ELSE IF (NRADIAL == 2) THEN - CALL FRMTFP (INDEX, NSUBS) - ELSE - CALL FRMHYD (INDEX, NSUBS, MODIFY) - ENDIF - - CALL PRTREM (ALL) + + IF (NRADIAL == 1) THEN + CALL FRMRWF (INDEX, NSUBS, INFILE) + ELSE IF (NRADIAL == 2) THEN + CALL FRMTFP (INDEX, NSUBS) + ELSE + CALL FRMHYD (INDEX, NSUBS, MODIFY) + ENDIF + + CALL PRTREM (ALL) !WRITE (istde,*) 'Radial functions incomplete, need more...' ! PRTREM has more informative prompt - IF (.NOT.ALL) GO TO 234 - - ENDIF + IF (.NOT.ALL) GO TO 234 + + ENDIF ! ! All read. Let know, and allow modifying if non default ! WRITE (ISTDE, *) 'All required subshell radial wavefunctions ', & - ' have been estimated:' - CALL SUMMRY (ISTDE) - - IF (NDEF == 0) THEN - MODIFY = .FALSE. - ELSE - WRITE (ISTDE, *) 'Revise any of these estimates?' - MODIFY = GETYN() - ENDIF - - IF (MODIFY) THEN - 456 CONTINUE + ' have been estimated:' + CALL SUMMRY (ISTDE) + + IF (NDEF == 0) THEN + MODIFY = .FALSE. + ELSE + WRITE (ISTDE, *) 'Revise any of these estimates?' + MODIFY = GETYN() + ENDIF + + IF (MODIFY) THEN + 456 CONTINUE WRITE (ISTDE, *) 'Enter the list of subshells whose radial ', & - 'wavefunctions are to be revised:' + 'wavefunctions are to be revised:' OPEN(UNIT=734, FILE='tmp_734', STATUS='NEW') - CALL GETRSL (INDEX, NSUBS) + CALL GETRSL (INDEX, NSUBS) CLOSE(734, STATUS='DELETE') - IF (NSUBS == 0) GO TO 456 - DO J = 1, NSUBS - LOC = INDEX(J) - SET(LOC) = .FALSE. - PF(:N,LOC) = 0.D0 - QF(:N,LOC) = 0.D0 - SOURCE(LOC) = ' ' - END DO - ALL = .FALSE. - GO TO 123 - ENDIF - - IF (NDEF /= 0) CALL SUMMRY (24) - - RETURN - END SUBROUTINE GENRWF + IF (NSUBS == 0) GO TO 456 + DO J = 1, NSUBS + LOC = INDEX(J) + SET(LOC) = .FALSE. + PF(:N,LOC) = 0.D0 + QF(:N,LOC) = 0.D0 + SOURCE(LOC) = ' ' + END DO + ALL = .FALSE. + GO TO 123 + ENDIF + + IF (NDEF /= 0) CALL SUMMRY (24) + + RETURN + END SUBROUTINE GENRWF diff --git a/src/appl/rwfnestimate90/genrwf_I.f90 b/src/appl/rwfnestimate90/genrwf_I.f90 index c6f011bbb..fe70bab50 100644 --- a/src/appl/rwfnestimate90/genrwf_I.f90 +++ b/src/appl/rwfnestimate90/genrwf_I.f90 @@ -1,7 +1,7 @@ - MODULE genrwf_I + MODULE genrwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE genrwf - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE genrwf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/getinf_I.f90 b/src/appl/rwfnestimate90/getinf_I.f90 index 4cbab67e1..de3780e34 100644 --- a/src/appl/rwfnestimate90/getinf_I.f90 +++ b/src/appl/rwfnestimate90/getinf_I.f90 @@ -1,7 +1,7 @@ - MODULE getinf_I + MODULE getinf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE getinf - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE getinf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/getinfo.f90 b/src/appl/rwfnestimate90/getinfo.f90 index 13e950132..72a1b9bfa 100644 --- a/src/appl/rwfnestimate90/getinfo.f90 +++ b/src/appl/rwfnestimate90/getinfo.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE GETINF + SUBROUTINE GETINF ! * ! Interactively determines data useful for generating estimates of * ! the subshell radial wavefunctions. * @@ -14,24 +14,24 @@ SUBROUTINE GETINF ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE IOUNIT_C - USE DEF_C - USE DEFAULT_C + USE vast_kind_param, ONLY: DOUBLE + USE IOUNIT_C + USE DEF_C + USE DEFAULT_C USE GRID_C, ONLY: RNT, H, HP, N - USE NPAR_C + USE NPAR_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE setqic_I - USE radgrd_I - USE nucpot_I + USE getyn_I + USE setiso_I + USE setqic_I + USE radgrd_I + USE nucpot_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -39,88 +39,88 @@ SUBROUTINE GETINF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: YES + LOGICAL :: YES !----------------------------------------------- ! ! ! ! Open, check, load data from, and close the .iso file ! - CALL SETISO ('isodata') + CALL SETISO ('isodata') ! ! Set defaults ! - C = CVAC + C = CVAC ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF .. should be Z-dependent - RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 + RNT = 2.0D-06/Z + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 ! - IF (NDEF /= 0) THEN + IF (NDEF /= 0) THEN WRITE (ISTDE, *) 'Change the default speed of light ', & - 'or radial grid parameters?' + 'or radial grid parameters?' ! - YES = GETYN() - IF (YES) THEN + YES = GETYN() + IF (YES) THEN ! ! Modify the speed of light ! WRITE (ISTDE, *) 'The physical speed of light in ', & - 'atomic units is', CVAC, ';' - WRITE (ISTDE, *) 'revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter the revised value:' - READ (5, *) C - ENDIF + 'atomic units is', CVAC, ';' + WRITE (ISTDE, *) 'revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter the revised value:' + READ (5, *) C + ENDIF ! ! Modify the parameters controlling the radial grid ! WRITE (ISTDE, *) 'The default radial grid parameters ', & - 'for this case are:' - WRITE (ISTDE, *) ' RNT = ', RNT, ';' - WRITE (ISTDE, *) ' H = ', H, ';' - WRITE (ISTDE, *) ' HP = ', HP, ';' - WRITE (ISTDE, *) ' N = ', N, ';' - WRITE (ISTDE, *) 'revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (ISTDE, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (ISTDE, *) 'Enter H:' - READ (5, *) H - WRITE (ISTDE, *) 'Enter HP:' - READ (5, *) HP - WRITE (ISTDE, *) 'Enter N:' - READ (5, *) N - ENDIF -! - ENDIF - ENDIF + 'for this case are:' + WRITE (ISTDE, *) ' RNT = ', RNT, ';' + WRITE (ISTDE, *) ' H = ', H, ';' + WRITE (ISTDE, *) ' HP = ', HP, ';' + WRITE (ISTDE, *) ' N = ', N, ';' + WRITE (ISTDE, *) 'revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (ISTDE, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (ISTDE, *) 'Enter H:' + READ (5, *) H + WRITE (ISTDE, *) 'Enter HP:' + READ (5, *) HP + WRITE (ISTDE, *) 'Enter N:' + READ (5, *) N + ENDIF +! + ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Generate $- r \times V_ (r)$ ! - CALL NUCPOT + CALL NUCPOT ! - RETURN - END SUBROUTINE GETINF + RETURN + END SUBROUTINE GETINF diff --git a/src/appl/rwfnestimate90/prtrem.f90 b/src/appl/rwfnestimate90/prtrem.f90 index 16ac4ee04..4e9e16bf3 100644 --- a/src/appl/rwfnestimate90/prtrem.f90 +++ b/src/appl/rwfnestimate90/prtrem.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE PRTREM(ALL) + SUBROUTINE PRTREM(ALL) ! * ! Prints a list of subshells that remain to be estimated. ALL is * ! .TRUE. if all subshells have been estimated and .FALSE. other- * @@ -14,79 +14,79 @@ SUBROUTINE PRTREM(ALL) ! * !*********************************************************************** !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE LEFT_C - USE ORB_C, ONLY: NW, NP, NAK, NH - USE IOUNIT_C -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 + USE LEFT_C + USE ORB_C, ONLY: NW, NP, NAK, NH + USE IOUNIT_C +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL , INTENT(OUT) :: ALL + LOGICAL , INTENT(OUT) :: ALL !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- -!... /ORB2/ -! COMMON /ORB2/ NCF, NW, PNTRIQ -! REAL PNTRIQ +!... /ORB2/ +! COMMON /ORB2/ NCF, NW, PNTRIQ +! REAL PNTRIQ !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IEND, IBEG, LENTH - CHARACTER :: RECORD*80, CNUM*2 + INTEGER :: I, IEND, IBEG, LENTH + CHARACTER :: RECORD*80, CNUM*2 !----------------------------------------------- ! ! ! Determine if there are any subshell radial wavefunctions that ! remain to be estimated ! - DO I = 1, NW - IF (SET(I)) CYCLE - ALL = .FALSE. - GO TO 2 - END DO - ALL = .TRUE. - GO TO 4 + DO I = 1, NW + IF (SET(I)) CYCLE + ALL = .FALSE. + GO TO 2 + END DO + ALL = .TRUE. + GO TO 4 ! ! Print a list of subshell radial wavefunctions that remain to ! be estimated; this list is no more than 80 characters wide ! - 2 CONTINUE + 2 CONTINUE WRITE (ISTDE, *) 'The following subshell radial wavefunctions ', & - 'remain to be estimated:' - IEND = 0 - DO I = 1, NW - IF (SET(I)) CYCLE - IF (IEND > 75) THEN - WRITE (ISTDE, *) RECORD(1:IEND) - IEND = 0 - ENDIF - IF (IEND > 0) THEN - IBEG = IEND + 1 - IEND = IBEG - RECORD(IBEG:IEND) = ' ' - ENDIF - IBEG = IEND + 1 - CALL CONVRT (NP(I), CNUM, LENTH) - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = CNUM(1:LENTH) - IF (NAK(I) < 0) THEN - LENTH = 1 - ELSE - LENTH = 2 - ENDIF - IBEG = IEND + 1 - IEND = IBEG + LENTH - 1 - RECORD(IBEG:IEND) = NH(I)(1:LENTH) - END DO - IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) + 'remain to be estimated:' + IEND = 0 + DO I = 1, NW + IF (SET(I)) CYCLE + IF (IEND > 75) THEN + WRITE (ISTDE, *) RECORD(1:IEND) + IEND = 0 + ENDIF + IF (IEND > 0) THEN + IBEG = IEND + 1 + IEND = IBEG + RECORD(IBEG:IEND) = ' ' + ENDIF + IBEG = IEND + 1 + CALL CONVRT (NP(I), CNUM, LENTH) + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = CNUM(1:LENTH) + IF (NAK(I) < 0) THEN + LENTH = 1 + ELSE + LENTH = 2 + ENDIF + IBEG = IEND + 1 + IEND = IBEG + LENTH - 1 + RECORD(IBEG:IEND) = NH(I)(1:LENTH) + END DO + IF (IEND > 1) WRITE (ISTDE, *) RECORD(1:IEND) ! - 4 CONTINUE - RETURN - END SUBROUTINE PRTREM + 4 CONTINUE + RETURN + END SUBROUTINE PRTREM diff --git a/src/appl/rwfnestimate90/prtrem_I.f90 b/src/appl/rwfnestimate90/prtrem_I.f90 index c950e8781..15964cd97 100644 --- a/src/appl/rwfnestimate90/prtrem_I.f90 +++ b/src/appl/rwfnestimate90/prtrem_I.f90 @@ -1,10 +1,10 @@ - MODULE prtrem_I + MODULE prtrem_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE prtrem (ALL) - INTEGER NNNW - PARAMETER (NNNW = 120) - LOGICAL, INTENT(OUT) :: ALL - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE prtrem (ALL) + INTEGER NNNW + PARAMETER (NNNW = 120) + LOGICAL, INTENT(OUT) :: ALL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/sbstep.f90 b/src/appl/rwfnestimate90/sbstep.f90 index a1733e17d..a94b3ae8d 100644 --- a/src/appl/rwfnestimate90/sbstep.f90 +++ b/src/appl/rwfnestimate90/sbstep.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE SBSTEP(IORB, NSTRT, NEND, P, Q) + SUBROUTINE SBSTEP(IORB, NSTRT, NEND, P, Q) ! * ! This subroutine continues the solution of the homogeneous Dirac * ! radial equation from tabulation point NSTRT to tabulation point * @@ -12,45 +12,45 @@ SUBROUTINE SBSTEP(IORB, NSTRT, NEND, P, Q) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP, NNN1, NNNW - !USE DEF_C - USE GRID_C - USE INT_C, ONLY: TF, TG - USE ORB_C - USE SBC_C + !USE DEF_C + USE GRID_C + USE INT_C, ONLY: TF, TG + USE ORB_C + USE SBC_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: IORB - INTEGER , INTENT(IN) :: NSTRT - INTEGER , INTENT(IN) :: NEND - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: IORB + INTEGER , INTENT(IN) :: NSTRT + INTEGER , INTENT(IN) :: NEND + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(INOUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: B1 = -0.50D00 - REAL(DOUBLE), PARAMETER :: B2 = 0.50D00 - REAL(DOUBLE), PARAMETER :: B3 = 0.75D00 - REAL(DOUBLE), PARAMETER :: B4 = 0.25D00 + REAL(DOUBLE), PARAMETER :: B1 = -0.50D00 + REAL(DOUBLE), PARAMETER :: B2 = 0.50D00 + REAL(DOUBLE), PARAMETER :: B3 = 0.75D00 + REAL(DOUBLE), PARAMETER :: B4 = 0.25D00 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IDIFF, LOC, J, JP1, JM1 + INTEGER :: IDIFF, LOC, J, JP1, JM1 REAL(DOUBLE) :: TBH, TC1, FK, CC, PJ, QJ, FAC, PPJ, QPJ, PJM1, QJM1, & PPJM1, QPJM1, PJM2, QJM2, PPJM2, QPJM2, PJM3, QJM3, PPJM3, QPJM3, PJM4& , QJM4, PPJM4, QPJM4, RPPJ, RQPJ, CCRPOR, CPJP1, CMJP1, FJP1, GJP1, & DENOM, FACTOR, PJP1, QJP1, PPJP1, QPJP1, PJP2, QJP2, PPJP2, QPJP2, & PJP3, QJP3, PPJP3, QPJP3, PJP4, QJP4, PPJP4, QPJP4, RPMJ, RQMJ, CPJM1& - , CMJM1, FJM1, GJM1 + , CMJM1, FJM1, GJM1 REAL(DOUBLE) :: C1, C2, C3, C4, C5, C6 - LOGICAL :: OUT + LOGICAL :: OUT !----------------------------------------------- ! ! @@ -62,212 +62,212 @@ SUBROUTINE SBSTEP(IORB, NSTRT, NEND, P, Q) C4 = C(4) C5 = C(5) C6 = C(6) - TBH = 2.0D00/H - TC1 = 2.0D00*C1 + TBH = 2.0D00/H + TC1 = 2.0D00*C1 ! ! Determine whether integration is inward or outwarD ! - IDIFF = NEND - NSTRT - IF (IDIFF > 0) THEN - OUT = .TRUE. - ELSE IF (IDIFF == 0) THEN - RETURN - ELSE IF (IDIFF < 0) THEN - OUT = .FALSE. - ENDIF + IDIFF = NEND - NSTRT + IF (IDIFF > 0) THEN + OUT = .TRUE. + ELSE IF (IDIFF == 0) THEN + RETURN + ELSE IF (IDIFF < 0) THEN + OUT = .FALSE. + ENDIF ! ! Overall initializations ! - FK = DBLE(NAK(IORB)) - CC = C1*FK*H + FK = DBLE(NAK(IORB)) + CC = C1*FK*H ! ! Perform integration depending on case ! - IF (OUT) THEN + IF (OUT) THEN ! ! Initialization for outward integration ! - LOC = NSTRT - PJ = P(LOC) - QJ = Q(LOC) - FAC = FK*RPOR(LOC) - PPJ = (-FAC*PJ) - TBH*TF(LOC)*QJ - QPJ = FAC*QJ - TBH*TG(LOC)*PJ -! - LOC = LOC - 1 - PJM1 = P(LOC) - QJM1 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJM1 = (-FAC*PJM1) - TBH*TF(LOC)*QJM1 - QPJM1 = FAC*QJM1 - TBH*TG(LOC)*PJM1 -! - LOC = LOC - 1 - PJM2 = P(LOC) - QJM2 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJM2 = (-FAC*PJM2) - TBH*TF(LOC)*QJM2 - QPJM2 = FAC*QJM2 - TBH*TG(LOC)*PJM2 -! - LOC = LOC - 1 - PJM3 = P(LOC) - QJM3 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJM3 = (-FAC*PJM3) - TBH*TF(LOC)*QJM3 - QPJM3 = FAC*QJM3 - TBH*TG(LOC)*PJM3 -! - LOC = LOC - 1 - PJM4 = P(LOC) - QJM4 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJM4 = (-FAC*PJM4) - TBH*TF(LOC)*QJM4 - QPJM4 = FAC*QJM4 - TBH*TG(LOC)*PJM4 + LOC = NSTRT + PJ = P(LOC) + QJ = Q(LOC) + FAC = FK*RPOR(LOC) + PPJ = (-FAC*PJ) - TBH*TF(LOC)*QJ + QPJ = FAC*QJ - TBH*TG(LOC)*PJ +! + LOC = LOC - 1 + PJM1 = P(LOC) + QJM1 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJM1 = (-FAC*PJM1) - TBH*TF(LOC)*QJM1 + QPJM1 = FAC*QJM1 - TBH*TG(LOC)*PJM1 +! + LOC = LOC - 1 + PJM2 = P(LOC) + QJM2 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJM2 = (-FAC*PJM2) - TBH*TF(LOC)*QJM2 + QPJM2 = FAC*QJM2 - TBH*TG(LOC)*PJM2 +! + LOC = LOC - 1 + PJM3 = P(LOC) + QJM3 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJM3 = (-FAC*PJM3) - TBH*TF(LOC)*QJM3 + QPJM3 = FAC*QJM3 - TBH*TG(LOC)*PJM3 +! + LOC = LOC - 1 + PJM4 = P(LOC) + QJM4 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJM4 = (-FAC*PJM4) - TBH*TF(LOC)*QJM4 + QPJM4 = FAC*QJM4 - TBH*TG(LOC)*PJM4 ! ! March out ! - J = NSTRT - 1 - 1 CONTINUE - J = J + 1 + J = NSTRT - 1 + 1 CONTINUE + J = J + 1 ! RPPJ = B1*PJ + B2*PJM1 + B3*PJM2 + B4*PJM3 + C2*PPJ + C3*PPJM1 + C4*& - PPJM2 + C5*PPJM3 + C6*PPJM4 + PPJM2 + C5*PPJM3 + C6*PPJM4 RQPJ = B1*QJ + B2*QJM1 + B3*QJM2 + B4*QJM3 + C2*QPJ + C3*QPJM1 + C4*& - QPJM2 + C5*QPJM3 + C6*QPJM4 -! - JP1 = J + 1 - CCRPOR = CC*RPOR(JP1) - CPJP1 = 1.0D00 + CCRPOR - CMJP1 = 1.0D00 - CCRPOR - FJP1 = TC1*TF(JP1) - GJP1 = TC1*TG(JP1) - DENOM = CPJP1*CMJP1 - GJP1*FJP1 - FACTOR = 1.0D00/DENOM - PJP1 = (CMJP1*RPPJ - FJP1*RQPJ)*FACTOR - QJP1 = (CPJP1*RQPJ - GJP1*RPPJ)*FACTOR - P(JP1) = PJP1 - Q(JP1) = QJP1 -! - IF (JP1 < NEND) THEN -! - PPJM4 = PPJM3 - QPJM4 = QPJM3 -! - PJM3 = PJM2 - QJM3 = QJM2 - PPJM3 = PPJM2 - QPJM3 = QPJM2 -! - PJM2 = PJM1 - QJM2 = QJM1 - PPJM2 = PPJM1 - QPJM2 = QPJM1 -! - PJM1 = PJ - QJM1 = QJ - PPJM1 = PPJ - QPJM1 = QPJ -! - PJ = PJP1 - QJ = QJP1 - FAC = FK*RPOR(JP1) - PPJ = (-FAC*PJ) - TBH*TF(JP1)*QJ - QPJ = FAC*QJ - TBH*TG(JP1)*PJ -! - GO TO 1 -! - ENDIF - ELSE + QPJM2 + C5*QPJM3 + C6*QPJM4 +! + JP1 = J + 1 + CCRPOR = CC*RPOR(JP1) + CPJP1 = 1.0D00 + CCRPOR + CMJP1 = 1.0D00 - CCRPOR + FJP1 = TC1*TF(JP1) + GJP1 = TC1*TG(JP1) + DENOM = CPJP1*CMJP1 - GJP1*FJP1 + FACTOR = 1.0D00/DENOM + PJP1 = (CMJP1*RPPJ - FJP1*RQPJ)*FACTOR + QJP1 = (CPJP1*RQPJ - GJP1*RPPJ)*FACTOR + P(JP1) = PJP1 + Q(JP1) = QJP1 +! + IF (JP1 < NEND) THEN +! + PPJM4 = PPJM3 + QPJM4 = QPJM3 +! + PJM3 = PJM2 + QJM3 = QJM2 + PPJM3 = PPJM2 + QPJM3 = QPJM2 +! + PJM2 = PJM1 + QJM2 = QJM1 + PPJM2 = PPJM1 + QPJM2 = QPJM1 +! + PJM1 = PJ + QJM1 = QJ + PPJM1 = PPJ + QPJM1 = QPJ +! + PJ = PJP1 + QJ = QJP1 + FAC = FK*RPOR(JP1) + PPJ = (-FAC*PJ) - TBH*TF(JP1)*QJ + QPJ = FAC*QJ - TBH*TG(JP1)*PJ +! + GO TO 1 +! + ENDIF + ELSE ! ! Initializations for inward integration ! - LOC = NSTRT - PJ = P(LOC) - QJ = Q(LOC) - FAC = FK*RPOR(LOC) - PPJ = (-FAC*PJ) - TBH*TF(LOC)*QJ - QPJ = FAC*QJ - TBH*TG(LOC)*PJ -! - LOC = LOC + 1 - PJP1 = P(LOC) - QJP1 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJP1 = (-FAC*PJP1) - TBH*TF(LOC)*QJP1 - QPJP1 = FAC*QJP1 - TBH*TG(LOC)*PJP1 -! - LOC = LOC + 1 - PJP2 = P(LOC) - QJP2 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJP2 = (-FAC*PJP2) - TBH*TF(LOC)*QJP2 - QPJP2 = FAC*QJP2 - TBH*TG(LOC)*PJP2 -! - LOC = LOC + 1 - PJP3 = P(LOC) - QJP3 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJP3 = (-FAC*PJP3) - TBH*TF(LOC)*QJP3 - QPJP3 = FAC*QJP3 - TBH*TG(LOC)*PJP3 -! - LOC = LOC + 1 - PJP4 = P(LOC) - QJP4 = Q(LOC) - FAC = FK*RPOR(LOC) - PPJP4 = (-FAC*PJP4) - TBH*TF(LOC)*QJP4 - QPJP4 = FAC*QJP4 - TBH*TG(LOC)*PJP4 + LOC = NSTRT + PJ = P(LOC) + QJ = Q(LOC) + FAC = FK*RPOR(LOC) + PPJ = (-FAC*PJ) - TBH*TF(LOC)*QJ + QPJ = FAC*QJ - TBH*TG(LOC)*PJ +! + LOC = LOC + 1 + PJP1 = P(LOC) + QJP1 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJP1 = (-FAC*PJP1) - TBH*TF(LOC)*QJP1 + QPJP1 = FAC*QJP1 - TBH*TG(LOC)*PJP1 +! + LOC = LOC + 1 + PJP2 = P(LOC) + QJP2 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJP2 = (-FAC*PJP2) - TBH*TF(LOC)*QJP2 + QPJP2 = FAC*QJP2 - TBH*TG(LOC)*PJP2 +! + LOC = LOC + 1 + PJP3 = P(LOC) + QJP3 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJP3 = (-FAC*PJP3) - TBH*TF(LOC)*QJP3 + QPJP3 = FAC*QJP3 - TBH*TG(LOC)*PJP3 +! + LOC = LOC + 1 + PJP4 = P(LOC) + QJP4 = Q(LOC) + FAC = FK*RPOR(LOC) + PPJP4 = (-FAC*PJP4) - TBH*TF(LOC)*QJP4 + QPJP4 = FAC*QJP4 - TBH*TG(LOC)*PJP4 ! ! March in ! - J = NSTRT + 1 - 2 CONTINUE - J = J - 1 + J = NSTRT + 1 + 2 CONTINUE + J = J - 1 ! RPMJ = B1*PJ + B2*PJP1 + B3*PJP2 + B4*PJP3 - C2*PPJ - C3*PPJP1 - C4*& - PPJP2 - C5*PPJP3 - C6*PPJP4 + PPJP2 - C5*PPJP3 - C6*PPJP4 RQMJ = B1*QJ + B2*QJP1 + B3*QJP2 + B4*QJP3 - C2*QPJ - C3*QPJP1 - C4*& - QPJP2 - C5*QPJP3 - C6*QPJP4 -! - JM1 = J - 1 - CCRPOR = CC*RPOR(JM1) - CPJM1 = 1.0D00 + CCRPOR - CMJM1 = 1.0D00 - CCRPOR - FJM1 = TC1*TF(JM1) - GJM1 = TC1*TG(JM1) - DENOM = CPJM1*CMJM1 - GJM1*FJM1 - FACTOR = 1.0D00/DENOM - PJM1 = (CPJM1*RPMJ + FJM1*RQMJ)*FACTOR - QJM1 = (CMJM1*RQMJ + GJM1*RPMJ)*FACTOR - P(JM1) = PJM1 - Q(JM1) = QJM1 -! - IF (JM1 > NEND) THEN -! - PPJP4 = PPJP3 - QPJP4 = QPJP3 -! - PJP3 = PJP2 - QJP3 = QJP2 - PPJP3 = PPJP2 - QPJP3 = QPJP2 -! - PJP2 = PJP1 - QJP2 = QJP1 - PPJP2 = PPJP1 - QPJP2 = QPJP1 -! - PJP1 = PJ - QJP1 = QJ - PPJP1 = PPJ - QPJP1 = QPJ -! - PJ = PJM1 - QJ = QJM1 - FAC = FK*RPOR(JM1) - PPJ = (-FAC*PJ) - TBH*TF(JM1)*QJ - QPJ = FAC*QJ - TBH*TG(JM1)*PJ -! - GO TO 2 -! - ENDIF - ENDIF -! - RETURN - END SUBROUTINE SBSTEP + QPJP2 - C5*QPJP3 - C6*QPJP4 +! + JM1 = J - 1 + CCRPOR = CC*RPOR(JM1) + CPJM1 = 1.0D00 + CCRPOR + CMJM1 = 1.0D00 - CCRPOR + FJM1 = TC1*TF(JM1) + GJM1 = TC1*TG(JM1) + DENOM = CPJM1*CMJM1 - GJM1*FJM1 + FACTOR = 1.0D00/DENOM + PJM1 = (CPJM1*RPMJ + FJM1*RQMJ)*FACTOR + QJM1 = (CMJM1*RQMJ + GJM1*RPMJ)*FACTOR + P(JM1) = PJM1 + Q(JM1) = QJM1 +! + IF (JM1 > NEND) THEN +! + PPJP4 = PPJP3 + QPJP4 = QPJP3 +! + PJP3 = PJP2 + QJP3 = QJP2 + PPJP3 = PPJP2 + QPJP3 = QPJP2 +! + PJP2 = PJP1 + QJP2 = QJP1 + PPJP2 = PPJP1 + QPJP2 = QPJP1 +! + PJP1 = PJ + QJP1 = QJ + PPJP1 = PPJ + QPJP1 = QPJ +! + PJ = PJM1 + QJ = QJM1 + FAC = FK*RPOR(JM1) + PPJ = (-FAC*PJ) - TBH*TF(JM1)*QJ + QPJ = FAC*QJ - TBH*TG(JM1)*PJ +! + GO TO 2 +! + ENDIF + ENDIF +! + RETURN + END SUBROUTINE SBSTEP diff --git a/src/appl/rwfnestimate90/sbstep_I.f90 b/src/appl/rwfnestimate90/sbstep_I.f90 index 52179d362..5beaad325 100644 --- a/src/appl/rwfnestimate90/sbstep_I.f90 +++ b/src/appl/rwfnestimate90/sbstep_I.f90 @@ -1,15 +1,15 @@ - MODULE sbstep_I + MODULE sbstep_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE sbstep (IORB, NSTRT, NEND, P, Q) - USE vast_kind_param,ONLY: DOUBLE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE sbstep (IORB, NSTRT, NEND, P, Q) + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP, NNN1, NNNW - INTEGER, INTENT(IN) :: IORB - INTEGER, INTENT(IN) :: NSTRT - INTEGER, INTENT(IN) :: NEND - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: IORB + INTEGER, INTENT(IN) :: NSTRT + INTEGER, INTENT(IN) :: NEND + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/screenpar.f90 b/src/appl/rwfnestimate90/screenpar.f90 index c0fc5abe8..ee7bf1793 100644 --- a/src/appl/rwfnestimate90/screenpar.f90 +++ b/src/appl/rwfnestimate90/screenpar.f90 @@ -1,7 +1,7 @@ !*********************************************************************** - SUBROUTINE SCREENPAR(NCORE) + SUBROUTINE SCREENPAR(NCORE) ! ! Purpose: ! Compute hydrogenic screen parameters @@ -14,33 +14,33 @@ SUBROUTINE SCREENPAR(NCORE) ! in the common - sigma() ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE ORB_C - USE HYDPAR_C, ONLY: SIGMA + USE vast_kind_param, ONLY: DOUBLE + USE ORB_C + USE HYDPAR_C, ONLY: SIGMA IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NCORE + INTEGER , INTENT(IN) :: NCORE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NELECTRON, I + INTEGER :: NELECTRON, I !----------------------------------------------- - + !...Core orbitals - NELECTRON = 0 - DO I = 1, NCORE - SIGMA(I) = NELECTRON + (NKJ(I)+1)/2 - NELECTRON = NELECTRON + NKJ(I) + 1 - END DO - + NELECTRON = 0 + DO I = 1, NCORE + SIGMA(I) = NELECTRON + (NKJ(I)+1)/2 + NELECTRON = NELECTRON + NKJ(I) + 1 + END DO + !...Peel orbitals - SIGMA(NCORE+1:NW) = NELECTRON - - RETURN - END SUBROUTINE SCREENPAR + SIGMA(NCORE+1:NW) = NELECTRON + + RETURN + END SUBROUTINE SCREENPAR diff --git a/src/appl/rwfnestimate90/screenpar_I.f90 b/src/appl/rwfnestimate90/screenpar_I.f90 index e896555ce..76bbb4c96 100644 --- a/src/appl/rwfnestimate90/screenpar_I.f90 +++ b/src/appl/rwfnestimate90/screenpar_I.f90 @@ -1,10 +1,10 @@ - MODULE screenpar_I + MODULE screenpar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE screenpar (NCORE) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, INTENT(IN) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE screenpar (NCORE) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, INTENT(IN) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/setdbg.f90 b/src/appl/rwfnestimate90/setdbg.f90 index 8a66dc999..cd8dfed13 100644 --- a/src/appl/rwfnestimate90/setdbg.f90 +++ b/src/appl/rwfnestimate90/setdbg.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG + SUBROUTINE SETDBG ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -12,95 +12,95 @@ SUBROUTINE SETDBG ! Written by Farid A Parpia Last update: 15 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE DEBUG_C - USE DEFAULT_C - USE IOUNIT_C + USE DEBUG_C + USE DEFAULT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I + USE getyn_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IERR - LOGICAL :: YES - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: I, IERR + LOGICAL :: YES + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! ! Initialise the arrays that control the debug printout ! - LDBPA = .FALSE. + LDBPA = .FALSE. ! - LDBPG = .FALSE. + LDBPG = .FALSE. ! - LDBPR = .FALSE. + LDBPR = .FALSE. ! - IF (NDEF == 0) RETURN - - WRITE (ISTDE, *) 'Generate debug printout?' - YES = GETYN() - IF (YES) THEN + IF (NDEF == 0) RETURN + + WRITE (ISTDE, *) 'Generate debug printout?' + YES = GETYN() + IF (YES) THEN ! ! The .dbg file is formatted; open it on unit 99 ! - DEFNAM = 'erwf.dbg' - FORM = 'FORMATTED' - STATUS = 'NEW' + DEFNAM = 'erwf.dbg' + FORM = 'FORMATTED' + STATUS = 'NEW' ! WRITE (ISTDE, *) 'File erwf.dbg will be created as the ', & - 'ERWF DeBuG Printout File; ' + 'ERWF DeBuG Printout File; ' WRITE (ISTDE, *) 'enter another file name if this is not ', & - 'acceptable; null otherwise:' - READ (*, '(A)') FILNAM + 'acceptable; null otherwise:' + READ (*, '(A)') FILNAM ! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM + IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM ! - 4 CONTINUE - CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 5 CONTINUE + 4 CONTINUE + CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 5 CONTINUE WRITE (ISTDE, *) 'Enter a name for the ERWF DeBuG Printout ', & - 'file that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 5 - GO TO 4 - ENDIF + 'file that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 5 + GO TO 4 + ENDIF ! ! Set options for general printout ! - WRITE (ISTDE, *) ' Print out the machine constants used?' - YES = GETYN() - IF (YES) LDBPG(1) = .TRUE. - WRITE (ISTDE, *) ' Print out the physical constants used?' - YES = GETYN() - IF (YES) LDBPG(2) = .TRUE. + WRITE (ISTDE, *) ' Print out the machine constants used?' + YES = GETYN() + IF (YES) LDBPG(1) = .TRUE. + WRITE (ISTDE, *) ' Print out the physical constants used?' + YES = GETYN() + IF (YES) LDBPG(2) = .TRUE. ! ! Set options for radial modules ! - WRITE (ISTDE, *) ' Printout from RADGRD?' - YES = GETYN() - IF (YES) LDBPR(1) = .TRUE. - WRITE (ISTDE, *) ' Printout from NUCPOT?' - YES = GETYN() - IF (YES) LDBPR(2) = .TRUE. - WRITE (ISTDE, *) ' Printout from TFPOT?' - YES = GETYN() - IF (YES) LDBPR(26) = .TRUE. + WRITE (ISTDE, *) ' Printout from RADGRD?' + YES = GETYN() + IF (YES) LDBPR(1) = .TRUE. + WRITE (ISTDE, *) ' Printout from NUCPOT?' + YES = GETYN() + IF (YES) LDBPR(2) = .TRUE. + WRITE (ISTDE, *) ' Printout from TFPOT?' + YES = GETYN() + IF (YES) LDBPR(26) = .TRUE. ! ! Set options for angular modules ! - WRITE (ISTDE, *) ' Printout from LODCSL?' - YES = GETYN() - IF (YES) LDBPA(1) = .TRUE. + WRITE (ISTDE, *) ' Printout from LODCSL?' + YES = GETYN() + IF (YES) LDBPA(1) = .TRUE. ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE SETDBG + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/rwfnestimate90/setdbg_I.f90 b/src/appl/rwfnestimate90/setdbg_I.f90 index 3fe256527..569a7f884 100644 --- a/src/appl/rwfnestimate90/setdbg_I.f90 +++ b/src/appl/rwfnestimate90/setdbg_I.f90 @@ -1,7 +1,7 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE setdbg - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE setdbg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/setsum.f90 b/src/appl/rwfnestimate90/setsum.f90 index 9dfd34802..ab24e6a10 100644 --- a/src/appl/rwfnestimate90/setsum.f90 +++ b/src/appl/rwfnestimate90/setsum.f90 @@ -2,8 +2,8 @@ !*********************************************************************** ! * - SUBROUTINE SETSUM - USE IOUNIT_C + SUBROUTINE SETSUM + USE IOUNIT_C ! * ! Open the .sum file on stream 24. * ! * @@ -12,48 +12,48 @@ SUBROUTINE SETSUM ! Written by Farid A. Parpia Last revision: 15 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: IERR + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! File erwf.sum is FORMATTED ! - DEFNAM = 'erwf.sum' - FORM = 'FORMATTED' - STATUS = 'NEW' + DEFNAM = 'erwf.sum' + FORM = 'FORMATTED' + STATUS = 'NEW' ! WRITE (ISTDE, *) 'File erwf.sum will be created as the ', & - 'ERWF SUMmary File; ' + 'ERWF SUMmary File; ' WRITE (ISTDE, *) 'enter another file name if this is not ', & - 'acceptable; null otherwise:' - READ (*, '(A)') FILNAM + 'acceptable; null otherwise:' + READ (*, '(A)') FILNAM ! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM + IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM ! - 1 CONTINUE - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 2 CONTINUE + 1 CONTINUE + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 2 CONTINUE WRITE (ISTDE, *) 'Enter a name for the ERWF SUMmary File ', & - 'that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 2 - GO TO 1 - ENDIF + 'that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 2 + GO TO 1 + ENDIF ! - RETURN - END SUBROUTINE SETSUM + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/rwfnestimate90/setsum_I.f90 b/src/appl/rwfnestimate90/setsum_I.f90 index 5fb0a6cdc..0c26f1ebd 100644 --- a/src/appl/rwfnestimate90/setsum_I.f90 +++ b/src/appl/rwfnestimate90/setsum_I.f90 @@ -1,7 +1,7 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE setsum - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE setsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/solvh.f90 b/src/appl/rwfnestimate90/solvh.f90 index 5acf796a6..1df055632 100644 --- a/src/appl/rwfnestimate90/solvh.f90 +++ b/src/appl/rwfnestimate90/solvh.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE SOLVH(IORB, FAIL) + SUBROUTINE SOLVH(IORB, FAIL) ! * ! This routine solves the homogeneous Dirac radial equation. * ! * @@ -18,215 +18,215 @@ SUBROUTINE SOLVH(IORB, FAIL) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE GRID_C - USE ORB_C - USE POTE_C, ONLY: YP - USE TATB_C, ONLY: TA, MTP + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE GRID_C + USE ORB_C + USE POTE_C, ONLY: YP + USE TATB_C, ONLY: TA, MTP USE WAVE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setpot_I - USE start_I - USE sbstep_I - USE tail_I - USE count_I - USE quad_I + USE setpot_I + USE start_I + USE sbstep_I + USE tail_I + USE count_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IORB - LOGICAL , INTENT(OUT) :: FAIL + INTEGER :: IORB + LOGICAL , INTENT(OUT) :: FAIL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: MXK, NPIORB, NKIORB, NAKABS, NLIORB, NNP, NREL, KOUNT, JP, & - ITYPE, NSTRT, I, NPC + ITYPE, NSTRT, I, NPC REAL(DOUBLE) :: EPSLON, CSQ, ALPHA, FKABS, FKAP2, ZALPHA, GAMMA, EBYM, & EMIN, EMAX, DELE, EEST, Q0, PFJPO, QFJPO, PFJPI, QFJPI, RATIO, SGN, & - DNORM, DMSMCH, DNFAC + DNORM, DMSMCH, DNFAC !----------------------------------------------- ! - DATA MXK/ 75/ + DATA MXK/ 75/ ! ! A solution is deemed continuous when the relative mismatch in the ! small component is within EPSLON ! - EPSLON = ACCY*0.1E00 + EPSLON = ACCY*0.1E00 ! ! Establish the number of nodes in the large component ! - NPIORB = NP(IORB) - NKIORB = NAK(IORB) - NAKABS = ABS(NKIORB) - IF (NKIORB < 0) THEN - NLIORB = NAKABS - 1 - ELSE - NLIORB = NAKABS - ENDIF - NNP = NPIORB - NLIORB - 1 + NPIORB = NP(IORB) + NKIORB = NAK(IORB) + NAKABS = ABS(NKIORB) + IF (NKIORB < 0) THEN + NLIORB = NAKABS - 1 + ELSE + NLIORB = NAKABS + ENDIF + NNP = NPIORB - NLIORB - 1 ! ! Establish the bounds on, and an estimate of, the eigenvalue ! - CSQ = C*C - ALPHA = 1.0D00/C - NREL = NPIORB - NAKABS - FKABS = DBLE(NAKABS) - FKAP2 = FKABS*FKABS -! - ZALPHA = YP(N)*ALPHA - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL + 0.5D00))**2) - EMIN = (1.0D00 - EBYM)*CSQ - ELSE - EMIN = 0.25D00*CSQ/DBLE(NPIORB*NPIORB) - ENDIF -! - ZALPHA = Z*ALPHA -! - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL))**2) - E(IORB) = (1.0D00 - EBYM)*CSQ - ELSE - E(IORB) = CSQ - ENDIF -! - IF (ZALPHA < FKABS) THEN - GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) - EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL - 0.5D00))**2) - EMAX = (1.0D00 - EBYM)*CSQ - ELSE - EMAX = CSQ + CSQ - ENDIF -! - DELE = 0.0D00 + CSQ = C*C + ALPHA = 1.0D00/C + NREL = NPIORB - NAKABS + FKABS = DBLE(NAKABS) + FKAP2 = FKABS*FKABS +! + ZALPHA = YP(N)*ALPHA + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL + 0.5D00))**2) + EMIN = (1.0D00 - EBYM)*CSQ + ELSE + EMIN = 0.25D00*CSQ/DBLE(NPIORB*NPIORB) + ENDIF +! + ZALPHA = Z*ALPHA +! + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL))**2) + E(IORB) = (1.0D00 - EBYM)*CSQ + ELSE + E(IORB) = CSQ + ENDIF +! + IF (ZALPHA < FKABS) THEN + GAMMA = SQRT(FKAP2 - ZALPHA*ZALPHA) + EBYM = 1.0D00/SQRT(1.0D00 + (ZALPHA/(GAMMA + NREL - 0.5D00))**2) + EMAX = (1.0D00 - EBYM)*CSQ + ELSE + EMAX = CSQ + CSQ + ENDIF +! + DELE = 0.0D00 ! ! Initialize ! - FAIL = .FALSE. - KOUNT = -1 + FAIL = .FALSE. + KOUNT = -1 ! ! Iteration loop begins here ! - 1 CONTINUE - KOUNT = KOUNT + 1 - IF (KOUNT > MXK) THEN - FAIL = .TRUE. - RETURN - ENDIF + 1 CONTINUE + KOUNT = KOUNT + 1 + IF (KOUNT > MXK) THEN + FAIL = .TRUE. + RETURN + ENDIF ! ! Generate estimate of eigenvalue for this iteration ! - EEST = E(IORB) + DELE - IF (EEST>EMIN .AND. EESTEMIN .AND. EEST NNP) THEN - EMIN = E(IORB) - DELE = 0.5D00*(EMAX - EMIN) - GO TO 1 - ELSE IF (NPC < NNP) THEN - EMAX = E(IORB) - DELE = -0.5D00*(EMAX - EMIN) - GO TO 1 - ENDIF + IF (NPC > NNP) THEN + EMIN = E(IORB) + DELE = 0.5D00*(EMAX - EMIN) + GO TO 1 + ELSE IF (NPC < NNP) THEN + EMAX = E(IORB) + DELE = -0.5D00*(EMAX - EMIN) + GO TO 1 + ENDIF ! ! Correct number of nodes ! ! Compute 'norm' of solution ! - TA(1) = 0.0D00 - TA(2:N) = (PF(2:N,IORB)**2+QF(2:N,IORB)**2)*RP(2:N) - MTP = N - CALL QUAD (DNORM) + TA(1) = 0.0D00 + TA(2:N) = (PF(2:N,IORB)**2+QF(2:N,IORB)**2)*RP(2:N) + MTP = N + CALL QUAD (DNORM) ! ! Determine correction to eigenvalue from magic formula ! correct slope at origin ! - QFJPI = QFJPI*RATIO - DMSMCH = QFJPI - QFJPO - IF (ABS(DMSMCH/QFJPO) > EPSLON) THEN - DELE = C*PF(JP,IORB)*DMSMCH/DNORM - IF (DELE < 0.0D00) THEN - EMAX = EMAX*(1.0D00 - 0.2E00*ABS(DELE/E(IORB))) - ELSE - EMIN = EMIN*(1.0D00 + 0.2E00*ABS(DELE/E(IORB))) - ENDIF - PZ(IORB) = PZ(IORB)/SQRT(DNORM) - GO TO 1 - ENDIF + QFJPI = QFJPI*RATIO + DMSMCH = QFJPI - QFJPO + IF (ABS(DMSMCH/QFJPO) > EPSLON) THEN + DELE = C*PF(JP,IORB)*DMSMCH/DNORM + IF (DELE < 0.0D00) THEN + EMAX = EMAX*(1.0D00 - 0.2E00*ABS(DELE/E(IORB))) + ELSE + EMIN = EMIN*(1.0D00 + 0.2E00*ABS(DELE/E(IORB))) + ENDIF + PZ(IORB) = PZ(IORB)/SQRT(DNORM) + GO TO 1 + ENDIF ! ! Normalize ! - DNFAC = 1.0D00/SQRT(DNORM) - PZ(IORB) = PZ(IORB)*DNFAC - PF(:N,IORB) = PF(:N,IORB)*DNFAC - QF(:N,IORB) = QF(:N,IORB)*DNFAC + DNFAC = 1.0D00/SQRT(DNORM) + PZ(IORB) = PZ(IORB)*DNFAC + PF(:N,IORB) = PF(:N,IORB)*DNFAC + QF(:N,IORB) = QF(:N,IORB)*DNFAC ! ! Find maximum tabulation point ! - I = N + 1 - 5 CONTINUE - I = I - 1 - IF (ABS(PF(I,IORB)) < EPSLON) THEN - PF(I,IORB) = 0.0D00 - QF(I,IORB) = 0.0D00 - GO TO 5 - ELSE - MF(IORB) = I - ENDIF -! - RETURN - END SUBROUTINE SOLVH + I = N + 1 + 5 CONTINUE + I = I - 1 + IF (ABS(PF(I,IORB)) < EPSLON) THEN + PF(I,IORB) = 0.0D00 + QF(I,IORB) = 0.0D00 + GO TO 5 + ELSE + MF(IORB) = I + ENDIF +! + RETURN + END SUBROUTINE SOLVH diff --git a/src/appl/rwfnestimate90/solvh_I.f90 b/src/appl/rwfnestimate90/solvh_I.f90 index 0f2d2eef1..b1f0236ca 100644 --- a/src/appl/rwfnestimate90/solvh_I.f90 +++ b/src/appl/rwfnestimate90/solvh_I.f90 @@ -1,15 +1,15 @@ - MODULE solvh_I + MODULE solvh_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:06:08 1/ 2/07 - SUBROUTINE solvh (IORB, FAIL) - INTEGER NNNP - PARAMETER (NNNP = 590) - INTEGER NNN1 - PARAMETER (NNN1 = 600) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, INTENT(IN) :: IORB - LOGICAL, INTENT(OUT) :: FAIL - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:06:08 1/ 2/07 + SUBROUTINE solvh (IORB, FAIL) + INTEGER NNNP + PARAMETER (NNNP = 590) + INTEGER NNN1 + PARAMETER (NNN1 = 600) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, INTENT(IN) :: IORB + LOGICAL, INTENT(OUT) :: FAIL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/strsum.f90 b/src/appl/rwfnestimate90/strsum.f90 index 3b0d47e8d..921ab5b21 100644 --- a/src/appl/rwfnestimate90/strsum.f90 +++ b/src/appl/rwfnestimate90/strsum.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * ! Generates the first part of erwf.sum (on stream 24). * ! * @@ -12,93 +12,93 @@ SUBROUTINE STRSUM ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE GRID_C - USE NPAR_C - USE NPOT_C, ONLY: NNUC - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE GRID_C + USE NPAR_C + USE NPOT_C, ONLY: NNUC + USE ORB_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE calen_I - USE convrt_I + USE calen_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH + INTEGER :: LENTH CHARACTER(LEN=10) :: CTIME - CHARACTER(LEN=8) :: CDATE - CHARACTER :: RECORD*256, CDATA*26 + CHARACTER(LEN=8) :: CDATE + CHARACTER :: RECORD*256, CDATA*26 !----------------------------------------------- ! ! ! Get the date and time of day; make this information the ! header of the summary file ! - CALL CALEN (CTIME, CDATE) - WRITE (24, *) 'ERWF run at ', CTIME, ' on ', CDATE, '.' + CALL CALEN (CTIME, CDATE) + WRITE (24, *) 'ERWF run at ', CTIME, ' on ', CDATE, '.' ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z - IF (NPARM == 2) THEN - WRITE (24, *) ' Fermi nucleus:' - WRITE (24, 302) PARM(1), PARM(2) - CALL CONVRT (NNUC, RECORD, LENTH) + WRITE (24, *) + WRITE (24, 300) Z + IF (NPARM == 2) THEN + WRITE (24, *) ' Fermi nucleus:' + WRITE (24, 302) PARM(1), PARM(2) + CALL CONVRT (NNUC, RECORD, LENTH) WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 303) C + WRITE (24, *) + WRITE (24, 303) C ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.0D00) THEN - WRITE (24, 305) RNT, H, N - ELSE - WRITE (24, 306) RNT, H, HP, N - ENDIF - WRITE (24, 307) R(1), R(2), R(N) + WRITE (24, *) + IF (HP == 0.0D00) THEN + WRITE (24, 305) RNT, H, N + ELSE + WRITE (24, 306) RNT, H, HP, N + ENDIF + WRITE (24, 307) R(1), R(2), R(N) ! - WRITE (24, *) + WRITE (24, *) ! - RETURN + RETURN ! - 300 FORMAT('The atomic number is ',1F14.10,';') - 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') + 300 FORMAT('The atomic number is ',1F14.10,';') + 302 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 303 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') 305 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 306 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 307 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') - RETURN + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/rwfnestimate90/strsum_I.f90 b/src/appl/rwfnestimate90/strsum_I.f90 index 761826f8d..352a74163 100644 --- a/src/appl/rwfnestimate90/strsum_I.f90 +++ b/src/appl/rwfnestimate90/strsum_I.f90 @@ -1,7 +1,7 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/summry.f90 b/src/appl/rwfnestimate90/summry.f90 index 3092eedef..1407af62c 100644 --- a/src/appl/rwfnestimate90/summry.f90 +++ b/src/appl/rwfnestimate90/summry.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE SUMMRY(NUNIT) + SUBROUTINE SUMMRY(NUNIT) ! * ! Prints a summary of the complete list of subshell radial wave- * ! functions on NUNIT. * @@ -13,15 +13,15 @@ SUBROUTINE SUMMRY(NUNIT) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE GRID_C - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE GRID_C + USE ORB_C USE WAVE_C - USE WHFROM_C, ONLY: SOURCE + USE WHFROM_C, ONLY: SOURCE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -29,29 +29,29 @@ SUBROUTINE SUMMRY(NUNIT) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NUNIT + INTEGER , INTENT(IN) :: NUNIT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, LENTH + INTEGER :: I, LENTH !----------------------------------------------- ! ! - WRITE (NUNIT, 300) + WRITE (NUNIT, 300) ! - DO I = 1, NW - LENTH = LEN_TRIM(SOURCE(I)) + DO I = 1, NW + LENTH = LEN_TRIM(SOURCE(I)) WRITE (NUNIT, 301) NP(I), NH(I), E(I), PZ(I), GAMA(I), PF(2,I), QF(2,I& - ), MF(I), SOURCE(I)(1:LENTH) + ), MF(I), SOURCE(I)(1:LENTH) ! WRITE (NUNIT,302) SOURCE(I)(1:LENTH) - END DO + END DO ! - RETURN + RETURN ! 300 FORMAT('Shell',6X,'e',11X,'p0',8X,'gamma',8X,'P(2)',7X,'Q(2)',6X,'MTP',& - ' SRC'/) - 301 FORMAT(1X,I2,A2,5D12.4,I5,2X,A3) - RETURN + ' SRC'/) + 301 FORMAT(1X,I2,A2,5D12.4,I5,2X,A3) + RETURN ! 302 FORMAT (' Source: ',A) ! - END SUBROUTINE SUMMRY + END SUBROUTINE SUMMRY diff --git a/src/appl/rwfnestimate90/summry_I.f90 b/src/appl/rwfnestimate90/summry_I.f90 index 5ba172a6b..155d1d7c3 100644 --- a/src/appl/rwfnestimate90/summry_I.f90 +++ b/src/appl/rwfnestimate90/summry_I.f90 @@ -1,12 +1,12 @@ - MODULE summry_I + MODULE summry_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE summry (NUNIT) - INTEGER NNN1 - PARAMETER (NNN1 = 600) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, INTENT(IN) :: NUNIT - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE summry (NUNIT) + INTEGER NNN1 + PARAMETER (NNN1 = 600) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, INTENT(IN) :: NUNIT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/tail.f90 b/src/appl/rwfnestimate90/tail.f90 index 75dfad7a1..de6e78514 100644 --- a/src/appl/rwfnestimate90/tail.f90 +++ b/src/appl/rwfnestimate90/tail.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE TAIL(IORB, P, Q, JP, MTP) + SUBROUTINE TAIL(IORB, P, Q, JP, MTP) ! * ! This subroutine begins the inward integration of the homogeneous * ! Dirac radial equation. With only minor modifications, the series * @@ -13,128 +13,128 @@ SUBROUTINE TAIL(IORB, P, Q, JP, MTP) ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEF_C, ONLY: ACCY, C, EXPMAX - USE GRID_C - USE ORB_C - USE POTE_C, ONLY: YP + USE DEF_C, ONLY: ACCY, C, EXPMAX + USE GRID_C + USE ORB_C + USE POTE_C, ONLY: YP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: IORB - INTEGER , INTENT(IN) :: JP - INTEGER , INTENT(OUT) :: MTP - REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) - REAL(DOUBLE) , INTENT(OUT) :: Q(NNNP) + INTEGER , INTENT(IN) :: IORB + INTEGER , INTENT(IN) :: JP + INTEGER , INTENT(OUT) :: MTP + REAL(DOUBLE) , INTENT(INOUT) :: P(NNNP) + REAL(DOUBLE) , INTENT(OUT) :: Q(NNNP) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, NM4, M, LOC + INTEGER :: I, NM4, M, LOC REAL(DOUBLE) :: EPS, BIGE, BIGEBC, BGEBC2, BETA, FK, RJP, QEM, OFFSET, T& , ZLOC, GAM2, ZLBB, DNU, FKMZBB, SUMP, SUMQ, EM, CM, EMFACT, OVLTRM, & - PTERM, QTERM, EXPTRM + PTERM, QTERM, EXPTRM !----------------------------------------------- ! ! ! Initialize ! - EPS = ACCY*0.1D00 - BIGE = -E(IORB) - BIGEBC = BIGE/C - BGEBC2 = BIGEBC/C - BETA = SQRT((-BIGE*(2.0D00 + BGEBC2))) - FK = DBLE(NAK(IORB)) + EPS = ACCY*0.1D00 + BIGE = -E(IORB) + BIGEBC = BIGE/C + BGEBC2 = BIGEBC/C + BETA = SQRT((-BIGE*(2.0D00 + BGEBC2))) + FK = DBLE(NAK(IORB)) ! ! Find MTP ! - I = JP - NM4 = N - 4 - RJP = R(JP) - QEM = 0.25D00*EXPMAX - 1 CONTINUE - I = I + 1 - IF (I <= NM4) THEN - IF (BETA*(R(I)-RJP) > QEM) THEN - MTP = I - ELSE - GO TO 1 - ENDIF - ELSE - WRITE (*, 300) - MTP = NM4 - ENDIF + I = JP + NM4 = N - 4 + RJP = R(JP) + QEM = 0.25D00*EXPMAX + 1 CONTINUE + I = I + 1 + IF (I <= NM4) THEN + IF (BETA*(R(I)-RJP) > QEM) THEN + MTP = I + ELSE + GO TO 1 + ENDIF + ELSE + WRITE (*, 300) + MTP = NM4 + ENDIF ! ! Compute offset for exponential function ! - OFFSET = BETA*R(MTP) + OFFSET = BETA*R(MTP) ! ! Tabulate tail points ! - DO I = MTP, N -! - T = 2.0D00*BETA*R(I) -! - ZLOC = YP(I) - GAM2 = FK**2 - (ZLOC/C)**2 - ZLBB = ZLOC/BETA - DNU = ZLBB*(1.0D00 + BGEBC2) - FKMZBB = FK - ZLBB -! - M = -1 - SUMP = 0.0D00 - SUMQ = 0.0D00 - M = M + 1 - EM = DBLE(M) - IF (M == 0) THEN - CM = 1.0D00 - EMFACT = 1.0D00 - ELSE - CM = CM*(GAM2 - (DNU - EM)**2) - EMFACT = EMFACT*EM - ENDIF - OVLTRM = CM*(T**(DNU - EM)/EMFACT) - PTERM = OVLTRM*(FKMZBB + EM)*BETA - QTERM = OVLTRM*(FKMZBB - EM)*BIGEBC - SUMP = SUMP + PTERM - SUMQ = SUMQ + QTERM - DO WHILE(ABS(PTERM/SUMP)>=EPS .OR. ABS(QTERM/SUMQ)>=EPS) - M = M + 1 - EM = DBLE(M) - IF (M == 0) THEN - CM = 1.0D00 - EMFACT = 1.0D00 - ELSE - CM = CM*(GAM2 - (DNU - EM)**2) - EMFACT = EMFACT*EM - ENDIF - OVLTRM = CM*(T**(DNU - EM)/EMFACT) - PTERM = OVLTRM*(FKMZBB + EM)*BETA - QTERM = OVLTRM*(FKMZBB - EM)*BIGEBC - SUMP = SUMP + PTERM - SUMQ = SUMQ + QTERM - END DO - EXPTRM = EXP((-0.5D00*T) + OFFSET) - P(I) = SUMP*EXPTRM - Q(I) = SUMQ*EXPTRM - IF (P(I) /= 0.0D00) CYCLE - LOC = I + 1 - GO TO 4 - END DO - LOC = N + 1 -! - 4 CONTINUE - P(LOC:N) = 0.0D00 - Q(LOC:N) = 0.0D00 -! - RETURN -! - 300 FORMAT('TAIL: Grid may be of insufficient extent') - RETURN -! - END SUBROUTINE TAIL + DO I = MTP, N +! + T = 2.0D00*BETA*R(I) +! + ZLOC = YP(I) + GAM2 = FK**2 - (ZLOC/C)**2 + ZLBB = ZLOC/BETA + DNU = ZLBB*(1.0D00 + BGEBC2) + FKMZBB = FK - ZLBB +! + M = -1 + SUMP = 0.0D00 + SUMQ = 0.0D00 + M = M + 1 + EM = DBLE(M) + IF (M == 0) THEN + CM = 1.0D00 + EMFACT = 1.0D00 + ELSE + CM = CM*(GAM2 - (DNU - EM)**2) + EMFACT = EMFACT*EM + ENDIF + OVLTRM = CM*(T**(DNU - EM)/EMFACT) + PTERM = OVLTRM*(FKMZBB + EM)*BETA + QTERM = OVLTRM*(FKMZBB - EM)*BIGEBC + SUMP = SUMP + PTERM + SUMQ = SUMQ + QTERM + DO WHILE(ABS(PTERM/SUMP)>=EPS .OR. ABS(QTERM/SUMQ)>=EPS) + M = M + 1 + EM = DBLE(M) + IF (M == 0) THEN + CM = 1.0D00 + EMFACT = 1.0D00 + ELSE + CM = CM*(GAM2 - (DNU - EM)**2) + EMFACT = EMFACT*EM + ENDIF + OVLTRM = CM*(T**(DNU - EM)/EMFACT) + PTERM = OVLTRM*(FKMZBB + EM)*BETA + QTERM = OVLTRM*(FKMZBB - EM)*BIGEBC + SUMP = SUMP + PTERM + SUMQ = SUMQ + QTERM + END DO + EXPTRM = EXP((-0.5D00*T) + OFFSET) + P(I) = SUMP*EXPTRM + Q(I) = SUMQ*EXPTRM + IF (P(I) /= 0.0D00) CYCLE + LOC = I + 1 + GO TO 4 + END DO + LOC = N + 1 +! + 4 CONTINUE + P(LOC:N) = 0.0D00 + Q(LOC:N) = 0.0D00 +! + RETURN +! + 300 FORMAT('TAIL: Grid may be of insufficient extent') + RETURN +! + END SUBROUTINE TAIL diff --git a/src/appl/rwfnestimate90/tail_I.f90 b/src/appl/rwfnestimate90/tail_I.f90 index 265cd95f2..eb0b59495 100644 --- a/src/appl/rwfnestimate90/tail_I.f90 +++ b/src/appl/rwfnestimate90/tail_I.f90 @@ -1,19 +1,19 @@ - MODULE tail_I + MODULE tail_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE tail (IORB, P, Q, JP, MTP) - USE vast_kind_param,ONLY: DOUBLE - INTEGER NNNP - PARAMETER (NNNP = 590) - INTEGER NNN1 - PARAMETER (NNN1 = 600) - INTEGER NNNW - PARAMETER (NNNW = 120) - INTEGER, INTENT(IN) :: IORB - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - REAL(DOUBLE), DIMENSION(NNNP), INTENT(OUT) :: Q - INTEGER, INTENT(IN) :: JP - INTEGER, INTENT(OUT) :: MTP - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE tail (IORB, P, Q, JP, MTP) + USE vast_kind_param,ONLY: DOUBLE + INTEGER NNNP + PARAMETER (NNNP = 590) + INTEGER NNN1 + PARAMETER (NNN1 = 600) + INTEGER NNNW + PARAMETER (NNNW = 120) + INTEGER, INTENT(IN) :: IORB + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + REAL(DOUBLE), DIMENSION(NNNP), INTENT(OUT) :: Q + INTEGER, INTENT(IN) :: JP + INTEGER, INTENT(OUT) :: MTP + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/tfpot.f90 b/src/appl/rwfnestimate90/tfpot.f90 index 5f014711a..7bd560cd0 100644 --- a/src/appl/rwfnestimate90/tfpot.f90 +++ b/src/appl/rwfnestimate90/tfpot.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE TFPOT + SUBROUTINE TFPOT ! * ! Calculation of the universal Thomas-Fermi potential. * ! * @@ -12,79 +12,79 @@ SUBROUTINE TFPOT ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE DEF_C, ONLY: Z, NELEC - USE GRID_C - USE NPOT_C, ONLY: ZZ - USE ORB_C - USE POTE_C, ONLY: YP + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE DEF_C, ONLY: Z, NELEC + USE GRID_C + USE NPOT_C, ONLY: ZZ + USE ORB_C + USE POTE_C, ONLY: YP !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE draw_I + USE draw_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, NB3, NROWS, II, II1, II2, II3 - REAL(DOUBLE) :: THIRD, WA, WB, WC, WD, WE, WF + INTEGER :: I, NB3, NROWS, II, II1, II2, II3 + REAL(DOUBLE) :: THIRD, WA, WB, WC, WD, WE, WF !----------------------------------------------- ! ! - THIRD = 1.0D00/3.0D00 + THIRD = 1.0D00/3.0D00 ! - WA = Z - DBLE(NELEC - 1) - WB = MAX(Z - WA,0.0D00) - WB = WB**THIRD/0.8853D00 - DO I = 1, N + WA = Z - DBLE(NELEC - 1) + WB = MAX(Z - WA,0.0D00) + WB = WB**THIRD/0.8853D00 + DO I = 1, N ! ! Rational function approximation to the universal Thomas-Fermi ! function ! - WC = SQRT(WB*R(I)) - WD = WC*(0.60112D0*WC + 1.81061D0) + 1.0D00 + WC = SQRT(WB*R(I)) + WD = WC*(0.60112D0*WC + 1.81061D0) + 1.0D00 WE = WC*(WC*(WC*(WC*(0.04793D0*WC + 0.21465D0) + 0.77112D0) + & - 1.39515D0) + 1.81061D0) + 1.0D00 - WF = WD/WE - YP(I) = (ZZ(I)-WA)*WF*WF + WA - END DO + 1.39515D0) + 1.81061D0) + 1.0D00 + WF = WD/WE + YP(I) = (ZZ(I)-WA)*WF*WF + WA + END DO ! ! Debug printout ! - IF (LDBPR(26)) THEN - WRITE (99, 300) - NB3 = N/3 - IF (3*NB3 == N) THEN - NROWS = NB3 - ELSE - NROWS = NB3 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - II3 = II2 + NROWS - IF (II3 <= N) THEN + IF (LDBPR(26)) THEN + WRITE (99, 300) + NB3 = N/3 + IF (3*NB3 == N) THEN + NROWS = NB3 + ELSE + NROWS = NB3 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + II3 = II2 + NROWS + IF (II3 <= N) THEN WRITE (99, 301) R(II1), YP(II1), R(II2), YP(II2), R(II3), YP(II3& - ) - ELSE IF (II2 <= N) THEN - WRITE (99, 301) R(II1), YP(II1), R(II2), YP(II2) - ELSE - WRITE (99, 301) R(II1), YP(II1) - ENDIF - END DO - CALL DRAW (YP, 1.0D00, YP, 1.0D00, N) - ENDIF + ) + ELSE IF (II2 <= N) THEN + WRITE (99, 301) R(II1), YP(II1), R(II2), YP(II2) + ELSE + WRITE (99, 301) R(II1), YP(II1) + ENDIF + END DO + CALL DRAW (YP, 1.0D00, YP, 1.0D00, N) + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,/,/,' Thomas-Fermi potential'/,/,3(& - ' --------- r --------- ------ -r*V(r) ------')) - 301 FORMAT(1P,6(1X,1D21.14)) - RETURN + ' --------- r --------- ------ -r*V(r) ------')) + 301 FORMAT(1P,6(1X,1D21.14)) + RETURN ! - END SUBROUTINE TFPOT + END SUBROUTINE TFPOT diff --git a/src/appl/rwfnestimate90/tfpot_I.f90 b/src/appl/rwfnestimate90/tfpot_I.f90 index e15049b6a..d7afd1236 100644 --- a/src/appl/rwfnestimate90/tfpot_I.f90 +++ b/src/appl/rwfnestimate90/tfpot_I.f90 @@ -1,7 +1,7 @@ - MODULE tfpot_I + MODULE tfpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE tfpot - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE tfpot + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/rwfnestimate90/wrtrwf.f90 b/src/appl/rwfnestimate90/wrtrwf.f90 index 5d82ea4db..586dd6492 100644 --- a/src/appl/rwfnestimate90/wrtrwf.f90 +++ b/src/appl/rwfnestimate90/wrtrwf.f90 @@ -2,7 +2,7 @@ !*********************************************************************** ! * - SUBROUTINE WRTRWF + SUBROUTINE WRTRWF ! * ! Open, write a header and all subshell radial wavefunctions, and * ! close the .rwf file. * @@ -13,71 +13,71 @@ SUBROUTINE WRTRWF ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:06:21 1/ 2/07 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE GRID_C - USE ORB_C - USE WAVE_C, ONLY: PZ, PF, QF, MF - USE IOUNIT_C + USE GRID_C + USE ORB_C + USE WAVE_C, ONLY: PZ, PF, QF, MF + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWUNIT, IERR, J, MFJ, I - LOGICAL :: IMOPENED - CHARACTER :: FILNAM*128 + INTEGER :: NEWUNIT, IERR, J, MFJ, I + LOGICAL :: IMOPENED + CHARACTER :: FILNAM*128 !----------------------------------------------- ! ! - - FILNAM = 'rwfn.inp' - - DO NEWUNIT = 23, 99 ! 23 is a historical value - INQUIRE(UNIT=NEWUNIT, OPENED=IMOPENED) - IF (IMOPENED) CYCLE - EXIT ! should be the normal exit point - END DO - - IF (NEWUNIT == 100) THEN - WRITE (ISTDE, *) 'All unit numbers from 23 to 99 are BUSY!' - STOP - ENDIF - - CALL OPENFL (NEWUNIT, FILNAM, 'UNFORMATTED', 'NEW', IERR) - IF (IERR == 1) THEN + + FILNAM = 'rwfn.inp' + + DO NEWUNIT = 23, 99 ! 23 is a historical value + INQUIRE(UNIT=NEWUNIT, OPENED=IMOPENED) + IF (IMOPENED) CYCLE + EXIT ! should be the normal exit point + END DO + + IF (NEWUNIT == 100) THEN + WRITE (ISTDE, *) 'All unit numbers from 23 to 99 are BUSY!' + STOP + ENDIF + + CALL OPENFL (NEWUNIT, FILNAM, 'UNFORMATTED', 'NEW', IERR) + IF (IERR == 1) THEN WRITE (ISTDE, *) 'Error when opening "', FILNAM(1:LEN_TRIM(FILNAM)), & - '"' - - STOP - ENDIF + '"' + + STOP + ENDIF ! ! Write the file header ! - WRITE (NEWUNIT) 'G92RWF' + WRITE (NEWUNIT) 'G92RWF' ! ! Write out the radial wavefunctions ! - DO J = 1, NW - MFJ = MF(J) - WRITE (NEWUNIT) NP(J), NAK(J), E(J), MFJ - WRITE (NEWUNIT) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) - WRITE (NEWUNIT) (R(I),I=1,MFJ) - END DO - - CLOSE(NEWUNIT) + DO J = 1, NW + MFJ = MF(J) + WRITE (NEWUNIT) NP(J), NAK(J), E(J), MFJ + WRITE (NEWUNIT) PZ(J), (PF(I,J),I=1,MFJ), (QF(I,J),I=1,MFJ) + WRITE (NEWUNIT) (R(I),I=1,MFJ) + END DO + + CLOSE(NEWUNIT) ! ! Deallocate the storage for the radial wavefunctions ! - CALL DALLOC (PF, 'PF', 'WRTRWF') - CALL DALLOC (QF, 'QF', 'WQRTRWF') + CALL DALLOC (PF, 'PF', 'WRTRWF') + CALL DALLOC (QF, 'QF', 'WQRTRWF') ! - RETURN - END SUBROUTINE WRTRWF + RETURN + END SUBROUTINE WRTRWF diff --git a/src/appl/rwfnestimate90/wrtrwf_I.f90 b/src/appl/rwfnestimate90/wrtrwf_I.f90 index 84a426f75..dd0b396e2 100644 --- a/src/appl/rwfnestimate90/wrtrwf_I.f90 +++ b/src/appl/rwfnestimate90/wrtrwf_I.f90 @@ -1,7 +1,7 @@ - MODULE wrtrwf_I + MODULE wrtrwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - SUBROUTINE wrtrwf - END SUBROUTINE - END INTERFACE - END MODULE +!...Generated by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + SUBROUTINE wrtrwf + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/Makefile b/src/appl/sms90/Makefile old mode 100755 new mode 100644 index 6052d5b3e..bec9c4c53 --- a/src/appl/sms90/Makefile +++ b/src/appl/sms90/Makefile @@ -12,7 +12,7 @@ MODLMCP90 = ${SRCLIBDIR}/libmcp90 GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} APP_OBJ= sms1_C.o teilst_C.o dvpot_C.o\ sms_I.o getmixblock_I.o rintiso_I.o smsmcp_I.o \ @@ -28,7 +28,7 @@ APP_OBJ= sms1_C.o teilst_C.o dvpot_C.o\ $(EXE): $(APP_OBJ) $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} + $(APP_LIBS) ${LAPACK_LIBS} .f90.o: $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ -I $(MODDIR) -o $@ @@ -38,4 +38,3 @@ $(EXE): $(APP_OBJ) clean: -rm -f *.o core *.mod - diff --git a/src/appl/sms90/densmcp.f90 b/src/appl/sms90/densmcp.f90 index dff1c81d2..e886f0acd 100644 --- a/src/appl/sms90/densmcp.f90 +++ b/src/appl/sms90/densmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DENSMCP(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) + SUBROUTINE DENSMCP(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! * ! This routine controls the main sequence of routine calls for the * ! calculation of the sms parameter, the electron density at the * @@ -16,11 +16,11 @@ SUBROUTINE DENSMCP(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! Last revision: 10 Nov 1995 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW @@ -29,11 +29,11 @@ SUBROUTINE DENSMCP(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) USE mcpa_C USE orb_C USE prnt_C - USE SMS1_C + USE SMS1_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -44,192 +44,192 @@ SUBROUTINE DENSMCP(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NDIM, NELMNT, I, IA, IR, IDIAG, IOS, LAB, NCONTR, IB, & - LOC, ICI, IRI, J + LOC, ICI, IRI, J REAL(DOUBLE), DIMENSION(:), pointer :: EMT1, EMT2, EMT3, EMT4, EMT5, & EMT6, Coeff REAL(DOUBLE) :: QA, DIAA1, DIAA2, DIAA3, DIAA4, & DIAA5, DIAA6, TEGRAL1, TEGRAL2, TEGRAL3, TEGRAL4, TEGRAL5, TEGRAL6, & - CONTRI1, CONTRI2, CONTRI3, CONTRI4, CONTRI5, CONTRI6 + CONTRI1, CONTRI2, CONTRI3, CONTRI4, CONTRI5, CONTRI6 INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, IENDC, IROW - LOGICAL :: SET + LOGICAL :: SET CHARACTER(LEN=7),PARAMETER :: name='densmcp' !----------------------------------------------- ! ! Allocate storage that is local to this subroutine ! - NDIM = 1 - CALL ALLOC (COEFF, NDIM, 'COEFF', name ) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', name) - CALL ALLOC (INDEX, NDIM, 'INDEX', name) + NDIM = 1 + CALL ALLOC (COEFF, NDIM, 'COEFF', name ) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', name) + CALL ALLOC (INDEX, NDIM, 'INDEX', name) ! - READ (30) NELMNT - CALL ALLOC (IENDC, 0, NCF, 'IENDC', name) - CALL ALLOC (IROW, NELMNT, 'IROW', name) - READ (30) (IENDC(I),I=0,NCF), (IROW(I),I=1,NELMNT) - CLOSE(30) + READ (30) NELMNT + CALL ALLOC (IENDC, 0, NCF, 'IENDC', name) + CALL ALLOC (IROW, NELMNT, 'IROW', name) + READ (30) (IENDC(I),I=0,NCF), (IROW(I),I=1,NELMNT) + CLOSE(30) ! ! Other initializations ! - CALL ALLOC (EMT1, NELMNT, 'EMT1', name) - CALL ALLOC (EMT2, NELMNT, 'EMT2', name ) - CALL ALLOC (EMT3, NELMNT, 'EMT3', name) - CALL ALLOC (EMT4, NELMNT, 'EMT4', name) - CALL ALLOC (EMT5, NELMNT, 'EMT5', name) - CALL ALLOC (EMT6, NELMNT, 'EMT6', name) + CALL ALLOC (EMT1, NELMNT, 'EMT1', name) + CALL ALLOC (EMT2, NELMNT, 'EMT2', name ) + CALL ALLOC (EMT3, NELMNT, 'EMT3', name) + CALL ALLOC (EMT4, NELMNT, 'EMT4', name) + CALL ALLOC (EMT5, NELMNT, 'EMT5', name) + CALL ALLOC (EMT6, NELMNT, 'EMT6', name) ! - EMT1(:NELMNT) = 0.0D00 - EMT2(:NELMNT) = 0.0D00 - EMT3(:NELMNT) = 0.0D00 - EMT4(:NELMNT) = 0.0D00 - EMT5(:NELMNT) = 0.0D00 - EMT6(:NELMNT) = 0.0D00 + EMT1(:NELMNT) = 0.0D00 + EMT2(:NELMNT) = 0.0D00 + EMT3(:NELMNT) = 0.0D00 + EMT4(:NELMNT) = 0.0D00 + EMT5(:NELMNT) = 0.0D00 + EMT6(:NELMNT) = 0.0D00 ! ! Accumulate diagonal terms that do not require MCP coefficients ! ! ! Piece involving I(a,a) integrals ! - DO IA = 1, NW - SET = .FALSE. - DO IR = 1, NCF - QA = DBLE(IQ(IA,IR)) - IF (QA <= 0.0D00) CYCLE - IF (.NOT.SET) THEN - DIAA1 = DINT1(IA,IA) - DIAA2 = DINT2(IA,IA) - DIAA3 = DINT3(IA,IA) - DIAA4 = DINT4(IA,IA) - DIAA5 = DINT5(IA,IA) - DIAA6 = DINT6(IA,IA) - SET = .TRUE. - ENDIF - IDIAG = IENDC(IR - 1) + 1 - EMT1(IDIAG) = EMT1(IDIAG) + QA*DIAA1 - EMT2(IDIAG) = EMT2(IDIAG) + QA*DIAA2 - EMT3(IDIAG) = EMT3(IDIAG) + QA*DIAA3 - EMT4(IDIAG) = EMT4(IDIAG) + QA*DIAA4 - EMT5(IDIAG) = EMT5(IDIAG) + QA*DIAA5 - EMT6(IDIAG) = EMT6(IDIAG) + QA*DIAA6 - END DO - END DO + DO IA = 1, NW + SET = .FALSE. + DO IR = 1, NCF + QA = DBLE(IQ(IA,IR)) + IF (QA <= 0.0D00) CYCLE + IF (.NOT.SET) THEN + DIAA1 = DINT1(IA,IA) + DIAA2 = DINT2(IA,IA) + DIAA3 = DINT3(IA,IA) + DIAA4 = DINT4(IA,IA) + DIAA5 = DINT5(IA,IA) + DIAA6 = DINT6(IA,IA) + SET = .TRUE. + ENDIF + IDIAG = IENDC(IR - 1) + 1 + EMT1(IDIAG) = EMT1(IDIAG) + QA*DIAA1 + EMT2(IDIAG) = EMT2(IDIAG) + QA*DIAA2 + EMT3(IDIAG) = EMT3(IDIAG) + QA*DIAA3 + EMT4(IDIAG) = EMT4(IDIAG) + QA*DIAA4 + EMT5(IDIAG) = EMT5(IDIAG) + QA*DIAA5 + EMT6(IDIAG) = EMT6(IDIAG) + QA*DIAA6 + END DO + END DO ! ! Accumulate one-electron terms that require MCP coefficients ! - REWIND (31) - READ (31) - READ (31) - READ (31) + REWIND (31) + READ (31) + READ (31) + READ (31) ! ! Attempt to read another block of data ! - 16 CONTINUE - READ (31, IOSTAT=IOS) LAB, NCONTR + 16 CONTINUE + READ (31, IOSTAT=IOS) LAB, NCONTR ! - IF (IOS == 0) THEN + IF (IOS == 0) THEN ! ! Read successful; decode the labels of I(ab) ! - IA = MOD(LAB,KEY) - IB = LAB/KEY + IA = MOD(LAB,KEY) + IB = LAB/KEY ! ! Compute I(ab) ! - TEGRAL1 = DINT1(IA,IB) - TEGRAL2 = DINT2(IA,IB) - TEGRAL3 = DINT3(IA,IB) - TEGRAL4 = DINT4(IA,IB) - TEGRAL5 = DINT5(IA,IB) - TEGRAL6 = DINT6(IA,IB) + TEGRAL1 = DINT1(IA,IB) + TEGRAL2 = DINT2(IA,IB) + TEGRAL3 = DINT3(IA,IB) + TEGRAL4 = DINT4(IA,IB) + TEGRAL5 = DINT5(IA,IB) + TEGRAL6 = DINT6(IA,IB) ! ! Ensure that storage is adequate to read in the rest of ! this block ! - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF, 'COEFF', name) - CALL DALLOC (ICLMN, 'ICLMN', name) - CALL DALLOC (INDEX, 'INDEX', name) - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM, 'COEFF', name) - CALL ALLOC (ICLMN, NDIM, 'ICLMN', name) - CALL ALLOC (INDEX, NDIM, 'INDEX', name) - ENDIF + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF, 'COEFF', name) + CALL DALLOC (ICLMN, 'ICLMN', name) + CALL DALLOC (INDEX, 'INDEX', name) + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM, 'COEFF', name) + CALL ALLOC (ICLMN, NDIM, 'ICLMN', name) + CALL ALLOC (INDEX, NDIM, 'INDEX', name) + ENDIF ! ! Read the column index, the sparse matrix index, and the ! coefficient for all contributions from this integral ! - READ (31) (ICLMN(I),INDEX(I),COEFF(I),I=1,NCONTR) + READ (31) (ICLMN(I),INDEX(I),COEFF(I),I=1,NCONTR) ! ! Store all the contributions from this integral ! - DO I = 1, NCONTR - LOC = INDEX(I) - EMT1(LOC) = EMT1(LOC) + TEGRAL1*COEFF(I) - EMT2(LOC) = EMT2(LOC) + TEGRAL2*COEFF(I) - EMT3(LOC) = EMT3(LOC) + TEGRAL3*COEFF(I) - EMT4(LOC) = EMT4(LOC) + TEGRAL4*COEFF(I) - EMT5(LOC) = EMT5(LOC) + TEGRAL5*COEFF(I) - EMT6(LOC) = EMT6(LOC) + TEGRAL6*COEFF(I) - END DO + DO I = 1, NCONTR + LOC = INDEX(I) + EMT1(LOC) = EMT1(LOC) + TEGRAL1*COEFF(I) + EMT2(LOC) = EMT2(LOC) + TEGRAL2*COEFF(I) + EMT3(LOC) = EMT3(LOC) + TEGRAL3*COEFF(I) + EMT4(LOC) = EMT4(LOC) + TEGRAL4*COEFF(I) + EMT5(LOC) = EMT5(LOC) + TEGRAL5*COEFF(I) + EMT6(LOC) = EMT6(LOC) + TEGRAL6*COEFF(I) + END DO ! ! Return to the start of the loop ! - GO TO 16 + GO TO 16 ! - ENDIF + ENDIF ! ! Deallocate storage that is local to this routine ! - CALL DALLOC (COEFF, 'COEFF', name) - CALL DALLOC (ICLMN, 'ICLMN', name) - CALL DALLOC (INDEX, 'INDEX', name) - - ICI = 0 - DO I = 1, NELMNT - IRI = IROW(I) - IF (I > IENDC(ICI)) ICI = ICI + 1 - DO J = 1, NVEC - LOC = (J - 1)*NCF - CONTRI1 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT1(I) - CONTRI2 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT2(I) - CONTRI3 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT3(I) - CONTRI4 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT4(I) - CONTRI5 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT5(I) - CONTRI6 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT6(I) - IF (IRI /= ICI) THEN - CONTRI1 = 2.0D00*CONTRI1 - CONTRI2 = 2.0D00*CONTRI2 - CONTRI3 = 2.0D00*CONTRI3 - CONTRI4 = 2.0D00*CONTRI4 - CONTRI5 = 2.0D00*CONTRI5 - CONTRI6 = 2.0D00*CONTRI6 - ENDIF - DENS1(J) = DENS1(J) + CONTRI1 - DENS2(J) = DENS2(J) + CONTRI2 - DENS3(J) = DENS3(J) + CONTRI3 - DENS4(J) = DENS4(J) + CONTRI4 - DENS5(J) = DENS5(J) + CONTRI5 - DENS6(J) = DENS6(J) + CONTRI6 - END DO - END DO - CALL DALLOC (EMT1, 'EMT1', name) - CALL DALLOC (EMT2, 'EMT2', name) - CALL DALLOC (EMT3, 'EMT3', name) - CALL DALLOC (EMT4, 'EMT4', name) - CALL DALLOC (EMT5, 'EMT5', name) - CALL DALLOC (EMT6, 'EMT6', name) - CALL DALLOC (IENDC, 'IENDC', name) - CALL DALLOC (IROW, 'IROW', name) + CALL DALLOC (COEFF, 'COEFF', name) + CALL DALLOC (ICLMN, 'ICLMN', name) + CALL DALLOC (INDEX, 'INDEX', name) + + ICI = 0 + DO I = 1, NELMNT + IRI = IROW(I) + IF (I > IENDC(ICI)) ICI = ICI + 1 + DO J = 1, NVEC + LOC = (J - 1)*NCF + CONTRI1 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT1(I) + CONTRI2 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT2(I) + CONTRI3 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT3(I) + CONTRI4 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT4(I) + CONTRI5 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT5(I) + CONTRI6 = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT6(I) + IF (IRI /= ICI) THEN + CONTRI1 = 2.0D00*CONTRI1 + CONTRI2 = 2.0D00*CONTRI2 + CONTRI3 = 2.0D00*CONTRI3 + CONTRI4 = 2.0D00*CONTRI4 + CONTRI5 = 2.0D00*CONTRI5 + CONTRI6 = 2.0D00*CONTRI6 + ENDIF + DENS1(J) = DENS1(J) + CONTRI1 + DENS2(J) = DENS2(J) + CONTRI2 + DENS3(J) = DENS3(J) + CONTRI3 + DENS4(J) = DENS4(J) + CONTRI4 + DENS5(J) = DENS5(J) + CONTRI5 + DENS6(J) = DENS6(J) + CONTRI6 + END DO + END DO + CALL DALLOC (EMT1, 'EMT1', name) + CALL DALLOC (EMT2, 'EMT2', name) + CALL DALLOC (EMT3, 'EMT3', name) + CALL DALLOC (EMT4, 'EMT4', name) + CALL DALLOC (EMT5, 'EMT5', name) + CALL DALLOC (EMT6, 'EMT6', name) + CALL DALLOC (IENDC, 'IENDC', name) + CALL DALLOC (IROW, 'IROW', name) ! ! Close the angular files ! - DO I = 30, 32 + KMAXF - CLOSE(I) - END DO - - RETURN - END SUBROUTINE DENSMCP + DO I = 30, 32 + KMAXF + CLOSE(I) + END DO + + RETURN + END SUBROUTINE DENSMCP diff --git a/src/appl/sms90/densmcp_I.f90 b/src/appl/sms90/densmcp_I.f90 index f7dc110b2..11e1f4fe5 100644 --- a/src/appl/sms90/densmcp_I.f90 +++ b/src/appl/sms90/densmcp_I.f90 @@ -1,17 +1,17 @@ - MODULE densmcp_I + MODULE densmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE densmcp (DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE densmcp (DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT1 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT2 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT3 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT4 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT5 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT6 - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT1 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT2 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT3 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT4 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT5 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT6 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/densnew.f90 b/src/appl/sms90/densnew.f90 index 0854d1176..e0d9fa151 100644 --- a/src/appl/sms90/densnew.f90 +++ b/src/appl/sms90/densnew.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DENSNEW(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) + SUBROUTINE DENSNEW(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! * ! This routine controls the main sequence of routine calls for the * ! calculation of the sms parameter, the electron density at the * @@ -17,34 +17,34 @@ SUBROUTINE DENSNEW(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! Last revision: Nov 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:42:57 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:42:57 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE debug_C USE decide_C - USE DEF_C + USE DEF_C USE eigv_C USE foparm_C USE grid_C - USE JLABL_C + USE JLABL_C USE npar_C USE orb_C - USE prnt_C - USE TEILST_C - USE BUFFER_C - USE SMS1_C + USE prnt_C + USE TEILST_C + USE BUFFER_C + USE SMS1_C USE syma_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcbuf_I - USE convrt_I + USE alcbuf_I + USE convrt_I USE getyn_I - USE itjpo_I - USE onescalar_I + USE itjpo_I + USE onescalar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -56,12 +56,12 @@ SUBROUTINE DENSNEW(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KA, IOPAR, INCOR, IC, LCNUM, ITJPOC, IR, IA, IB, J, LOC - REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL + REAL(DOUBLE), DIMENSION(NNNW) :: TSHELL REAL(DOUBLE), DIMENSION(:), pointer :: EMT1, EMT2, EMT3, EMT4, EMT5, EMT6 REAL(DOUBLE) :: ELEMNT1, ELEMNT2, ELEMNT3, ELEMNT4, ELEMNT5, ELEMNT6, & - CONTRI1, CONTRI2, CONTRI3, CONTRI4, CONTRI5, CONTRI6 - LOGICAL :: VSH, NUCDE, SMSSH, YES - CHARACTER :: CNUM*11, CK*2 + CONTRI1, CONTRI2, CONTRI3, CONTRI4, CONTRI5, CONTRI6 + LOGICAL :: VSH, NUCDE, SMSSH, YES + CHARACTER :: CNUM*11, CK*2 !----------------------------------------------- ! ! Matrix elements smaller than CUTOFF are not accumulated @@ -70,98 +70,98 @@ SUBROUTINE DENSNEW(DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) ! Set the rank (zero) and parity (even) for the one-particle ! coefficients ! - KA = 0 - IOPAR = 1 - INCOR = 1 + KA = 0 + IOPAR = 1 + INCOR = 1 ! ! Allocate storage for the arrays in BUFFER ! - CALL ALCBUF (1) + CALL ALCBUF (1) ! ! Sweep through the Hamiltonian matrix to determine the ! sms parameter ! - DO IC = 1, NCF + DO IC = 1, NCF ! ! Output IC on the screen to show how far the calculation has preceede ! - CALL CONVRT (IC, CNUM, LCNUM) + CALL CONVRT (IC, CNUM, LCNUM) IF (MOD(IC,10) == 0) WRITE (6, *) 'Column '//CNUM(1:LCNUM)//& - ' complete;' + ' complete;' ! - ITJPOC = ITJPO(IC) - DO IR = IC, NCF + ITJPOC = ITJPO(IC) + DO IR = IC, NCF ! ! Matrix elements are diagonal in J ! - IF (ITJPO(IR) /= ITJPOC) CYCLE + IF (ITJPO(IR) /= ITJPOC) CYCLE ! ! Initialise the accumulator ! - ELEMNT1 = 0.0D00 - ELEMNT2 = 0.0D00 - ELEMNT3 = 0.0D00 - ELEMNT4 = 0.0D00 - ELEMNT5 = 0.0D00 - ELEMNT6 = 0.0D00 + ELEMNT1 = 0.0D00 + ELEMNT2 = 0.0D00 + ELEMNT3 = 0.0D00 + ELEMNT4 = 0.0D00 + ELEMNT5 = 0.0D00 + ELEMNT6 = 0.0D00 ! ! Call the MCT package to compute T coefficients ! CALL ONESCALAR(IC,IR,IA,IB,TSHELL) -! CALL TNSRJJ (KA, IOPAR, IC, IR, IA, IB, TSHELL) - - IF (IA /= 0) THEN - IF (IA == IB) THEN - DO IA = 1, NW - IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE - ELEMNT1 = ELEMNT1 + DINT1(IA,IA)*TSHELL(IA) - ELEMNT2 = ELEMNT2 + DINT2(IA,IA)*TSHELL(IA) - ELEMNT3 = ELEMNT3 + DINT3(IA,IA)*TSHELL(IA) - ELEMNT4 = ELEMNT4 + DINT4(IA,IA)*TSHELL(IA) - ELEMNT5 = ELEMNT5 + DINT5(IA,IA)*TSHELL(IA) - ELEMNT6 = ELEMNT6 + DINT6(IA,IA)*TSHELL(IA) - END DO - ELSE - IF (ABS(TSHELL(1)) > CUTOFF) THEN - IF (NAK(IA) == NAK(IB)) THEN - ELEMNT1 = ELEMNT1 + DINT1(IA,IB)*TSHELL(1) - ELEMNT2 = ELEMNT2 + DINT2(IA,IB)*TSHELL(1) - ELEMNT3 = ELEMNT3 + DINT3(IA,IB)*TSHELL(1) - ELEMNT4 = ELEMNT4 + DINT4(IA,IB)*TSHELL(1) - ELEMNT5 = ELEMNT5 + DINT5(IA,IB)*TSHELL(1) - ELEMNT6 = ELEMNT6 + DINT6(IA,IB)*TSHELL(1) - ENDIF - ENDIF - ENDIF - ENDIF - DO J = 1, NVEC - LOC = (J - 1)*NCF - CONTRI1 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT1 - CONTRI2 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT2 - CONTRI3 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT3 - CONTRI4 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT4 - CONTRI5 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT5 - CONTRI6 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT6 - IF (IR /= IC) THEN - CONTRI1 = 2.0D00*CONTRI1 - CONTRI2 = 2.0D00*CONTRI2 - CONTRI3 = 2.0D00*CONTRI3 - CONTRI4 = 2.0D00*CONTRI4 - CONTRI5 = 2.0D00*CONTRI5 - CONTRI6 = 2.0D00*CONTRI6 - ENDIF - DENS1(J) = DENS1(J) + CONTRI1 - DENS2(J) = DENS2(J) + CONTRI2 - DENS3(J) = DENS3(J) + CONTRI3 - DENS4(J) = DENS4(J) + CONTRI4 - DENS5(J) = DENS5(J) + CONTRI5 - DENS6(J) = DENS6(J) + CONTRI6 - END DO - END DO - END DO +! CALL TNSRJJ (KA, IOPAR, IC, IR, IA, IB, TSHELL) + + IF (IA /= 0) THEN + IF (IA == IB) THEN + DO IA = 1, NW + IF (ABS(TSHELL(IA)) <= CUTOFF) CYCLE + ELEMNT1 = ELEMNT1 + DINT1(IA,IA)*TSHELL(IA) + ELEMNT2 = ELEMNT2 + DINT2(IA,IA)*TSHELL(IA) + ELEMNT3 = ELEMNT3 + DINT3(IA,IA)*TSHELL(IA) + ELEMNT4 = ELEMNT4 + DINT4(IA,IA)*TSHELL(IA) + ELEMNT5 = ELEMNT5 + DINT5(IA,IA)*TSHELL(IA) + ELEMNT6 = ELEMNT6 + DINT6(IA,IA)*TSHELL(IA) + END DO + ELSE + IF (ABS(TSHELL(1)) > CUTOFF) THEN + IF (NAK(IA) == NAK(IB)) THEN + ELEMNT1 = ELEMNT1 + DINT1(IA,IB)*TSHELL(1) + ELEMNT2 = ELEMNT2 + DINT2(IA,IB)*TSHELL(1) + ELEMNT3 = ELEMNT3 + DINT3(IA,IB)*TSHELL(1) + ELEMNT4 = ELEMNT4 + DINT4(IA,IB)*TSHELL(1) + ELEMNT5 = ELEMNT5 + DINT5(IA,IB)*TSHELL(1) + ELEMNT6 = ELEMNT6 + DINT6(IA,IB)*TSHELL(1) + ENDIF + ENDIF + ENDIF + ENDIF + DO J = 1, NVEC + LOC = (J - 1)*NCF + CONTRI1 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT1 + CONTRI2 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT2 + CONTRI3 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT3 + CONTRI4 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT4 + CONTRI5 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT5 + CONTRI6 = EVEC(IC + LOC)*EVEC(IR + LOC)*ELEMNT6 + IF (IR /= IC) THEN + CONTRI1 = 2.0D00*CONTRI1 + CONTRI2 = 2.0D00*CONTRI2 + CONTRI3 = 2.0D00*CONTRI3 + CONTRI4 = 2.0D00*CONTRI4 + CONTRI5 = 2.0D00*CONTRI5 + CONTRI6 = 2.0D00*CONTRI6 + ENDIF + DENS1(J) = DENS1(J) + CONTRI1 + DENS2(J) = DENS2(J) + CONTRI2 + DENS3(J) = DENS3(J) + CONTRI3 + DENS4(J) = DENS4(J) + CONTRI4 + DENS5(J) = DENS5(J) + CONTRI5 + DENS6(J) = DENS6(J) + CONTRI6 + END DO + END DO + END DO ! ! Deallocate storage for the arrays in BUFFER ! - CALL ALCBUF (3) - RETURN - END SUBROUTINE DENSNEW + CALL ALCBUF (3) + RETURN + END SUBROUTINE DENSNEW diff --git a/src/appl/sms90/densnew_I.f90 b/src/appl/sms90/densnew_I.f90 index 10c520acf..9fda6e3c3 100644 --- a/src/appl/sms90/densnew_I.f90 +++ b/src/appl/sms90/densnew_I.f90 @@ -1,17 +1,17 @@ - MODULE densnew_I + MODULE densnew_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:42:57 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:42:57 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE densnew (DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE densnew (DINT1, DINT2, DINT3, DINT4, DINT5, DINT6) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT1 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT2 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT3 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT4 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT5 - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT6 - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT1 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT2 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT3 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT4 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT5 + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: DINT6 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/dvpot_C.f90 b/src/appl/sms90/dvpot_C.f90 index 71c25353f..292553e34 100644 --- a/src/appl/sms90/dvpot_C.f90 +++ b/src/appl/sms90/dvpot_C.f90 @@ -1,5 +1,5 @@ MODULE dvpot_C -!...Created by Charlotte Froese Fischer +!...Created by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP diff --git a/src/appl/sms90/engout.f90 b/src/appl/sms90/engout.f90 index 545e35f01..e8545da56 100644 --- a/src/appl/sms90/engout.f90 +++ b/src/appl/sms90/engout.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) + SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! * ! This subroutine prints energy levels, splittings, and energies * ! relative to the lowest in Hartrees, Kaysers, and eV, using the * @@ -13,90 +13,90 @@ SUBROUTINE ENGOUT(EAV, E, JTOT, IPAR, ILEV, NN, MODE) ! Last updated: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:24 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:24 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C, ONLY: AUCM, AUEV - USE JLABL_C + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C, ONLY: AUCM, AUEV + USE JLABL_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - REAL(DOUBLE), INTENT(IN) :: EAV - INTEGER, INTENT(IN) :: JTOT(NN) - INTEGER, INTENT(IN) :: IPAR(NN) - INTEGER, INTENT(IN) :: ILEV(NN) - REAL(DOUBLE), INTENT(IN) :: E(NN) + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + REAL(DOUBLE), INTENT(IN) :: EAV + INTEGER, INTENT(IN) :: JTOT(NN) + INTEGER, INTENT(IN) :: IPAR(NN) + INTEGER, INTENT(IN) :: ILEV(NN) + REAL(DOUBLE), INTENT(IN) :: E(NN) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, IP - REAL(DOUBLE) :: EAU, ECM, EEV + INTEGER :: J, I, IP + REAL(DOUBLE) :: EAU, ECM, EEV !----------------------------------------------- ! ! Always print the eigenenergies ! - WRITE (24, 300) - WRITE (24, 301) - DO J = 1, NN - I = ILEV(J) - EAU = E(J) + EAV - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV + WRITE (24, 300) + WRITE (24, 301) + DO J = 1, NN + I = ILEV(J) + EAU = E(J) + EAV + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV ! WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO + END DO ! - IF (NN > 1) THEN + IF (NN > 1) THEN ! ! Energy separations ! - IF (MODE==1 .OR. MODE==3) THEN - WRITE (24, 303) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(J-1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV + IF (MODE==1 .OR. MODE==3) THEN + WRITE (24, 303) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(J-1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV ! WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + END DO + ENDIF ! ! Energies relative to level 1 ! - IF (MODE==2 .OR. MODE==3) THEN - WRITE (24, 304) - WRITE (24, 301) - DO J = 2, NN - I = ILEV(J) - EAU = E(J) - E(1) - ECM = EAU*AUCM - EEV = EAU*AUEV - IP = (IPAR(J)+3)/2 - WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV + IF (MODE==2 .OR. MODE==3) THEN + WRITE (24, 304) + WRITE (24, 301) + DO J = 2, NN + I = ILEV(J) + EAU = E(J) - E(1) + ECM = EAU*AUCM + EEV = EAU*AUEV + IP = (IPAR(J)+3)/2 + WRITE (24, 302) I, JLBR(JTOT(J)), JLBP(IP), EAU, ECM, EEV ! WRITE (24, 302) I, LABJ(JTOT(J)), LABP(IP), EAU, ECM, EEV - END DO - ENDIF + END DO + ENDIF ! - ENDIF + ENDIF ! - RETURN + RETURN ! - 300 FORMAT(/,'Eigenenergies:') - 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) - 302 FORMAT(1I3,2X,2A4,1P,3D22.14) - 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') - 304 FORMAT(/,'Energy of each level relative to lowest level:') - RETURN + 300 FORMAT(/,'Eigenenergies:') + 301 FORMAT(/,'Level J Parity',7X,'Hartrees',14X,'Kaysers',16X,'eV'/) + 302 FORMAT(1I3,2X,2A4,1P,3D22.14) + 303 FORMAT(/,'Energy of each level relative to immediately lower',' level:') + 304 FORMAT(/,'Energy of each level relative to lowest level:') + RETURN ! - END SUBROUTINE ENGOUT + END SUBROUTINE ENGOUT diff --git a/src/appl/sms90/engout_I.f90 b/src/appl/sms90/engout_I.f90 index f6c73893f..3b85e10d3 100644 --- a/src/appl/sms90/engout_I.f90 +++ b/src/appl/sms90/engout_I.f90 @@ -1,17 +1,17 @@ - MODULE engout_I + MODULE engout_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:24 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:24 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: EAV - REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E - INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT - INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR - INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV - INTEGER, INTENT(IN) :: NN - INTEGER, INTENT(IN) :: MODE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE engout (EAV, E, JTOT, IPAR, ILEV, NN, MODE) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: EAV + REAL(DOUBLE), DIMENSION(NN), INTENT(IN) :: E + INTEGER, DIMENSION(NN), INTENT(IN) :: JTOT + INTEGER, DIMENSION(NN), INTENT(IN) :: IPAR + INTEGER, DIMENSION(NN), INTENT(IN) :: ILEV + INTEGER, INTENT(IN) :: NN + INTEGER, INTENT(IN) :: MODE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/gco.f90 b/src/appl/sms90/gco.f90 index b53ff98b5..fce0572bc 100644 --- a/src/appl/sms90/gco.f90 +++ b/src/appl/sms90/gco.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) + REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! * ! This routine evaluates a coefficient * ! * @@ -19,45 +19,45 @@ REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB) ! Written by Farid A Parpia, at Oxford Last revision: 18 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:06:32 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE orb_C, IIQA=>IQA !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I USE IQ_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB + INTEGER :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQA, IQB - REAL(DOUBLE) :: FAC + INTEGER :: IQA, IQB + REAL(DOUBLE) :: FAC !----------------------------------------------- ! IQA = IQ (IA,IR) IQB = IQ (IB,IR) -!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) -!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) - IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN - FAC = CLRX(NAK(IA),K,NAK(IB)) - GCO = -DBLE(IQA*IQB)*FAC*FAC - ELSE - GCO = 0.0D00 - ENDIF - - RETURN - END FUNCTION GCO +!GG IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8) +!GG IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8) + IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN + FAC = CLRX(NAK(IA),K,NAK(IB)) + GCO = -DBLE(IQA*IQB)*FAC*FAC + ELSE + GCO = 0.0D00 + ENDIF + + RETURN + END FUNCTION GCO diff --git a/src/appl/sms90/gco_I.f90 b/src/appl/sms90/gco_I.f90 index 5a759536a..f5a176568 100644 --- a/src/appl/sms90/gco_I.f90 +++ b/src/appl/sms90/gco_I.f90 @@ -1,13 +1,13 @@ - MODULE gco_I + MODULE gco_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) - INTEGER :: K - INTEGER :: IR - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION gco (K, IR, IA, IB) + INTEGER :: K + INTEGER :: IR + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/sms90/getmixblock.f90 b/src/appl/sms90/getmixblock.f90 index f2e824048..1691bb917 100644 --- a/src/appl/sms90/getmixblock.f90 +++ b/src/appl/sms90/getmixblock.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE GETMIXBLOCK(NAME, NCI) + SUBROUTINE GETMIXBLOCK(NAME, NCI) ! ! Reads mixing coefficient file from block-structured format ! @@ -12,88 +12,88 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! written by Per Jonsson, September 2003 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:44:59 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:44:59 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man USE def_C USE eigv_C - USE IOUNIT_C + USE IOUNIT_C USE orb_C USE prnt_C USE syma_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCI - CHARACTER, INTENT(IN) :: NAME*24 + INTEGER, INTENT(IN) :: NCI + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: K, IERR, IOS, NCFTOT, NVECTOT, NVECSIZ, NBLOCK, I, NVECPAT, & - NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J - REAL(DOUBLE) :: EAVSUM - CHARACTER :: FILNAM*256, FORM*11, G92MIX*6, STATUS*3 + NCFPAT, NVECSIZPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J + REAL(DOUBLE) :: EAVSUM + CHARACTER :: FILNAM*256, FORM*11, G92MIX*6, STATUS*3 ! CHARACTER, PARAMETER :: name = 'GETMIXBLOCK' !----------------------------------------------- ! ! The .mix file is UNFORMATTED; it must exist ! - K = INDEX(NAME,' ') - IF (NCI == 0) THEN - FILNAM = NAME(1:K-1)//'.cm' - ELSE - FILNAM = NAME(1:K-1)//'.m' - ENDIF - FORM = 'UNFORMATTED' - STATUS = 'OLD' + K = INDEX(NAME,' ') + IF (NCI == 0) THEN + FILNAM = NAME(1:K-1)//'.cm' + ELSE + FILNAM = NAME(1:K-1)//'.m' + ENDIF + FORM = 'UNFORMATTED' + STATUS = 'OLD' ! - CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (ISTDE, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (25, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (ISTDE, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the header of the file; if not as expected, try again ! - READ (25, IOSTAT=IOS) G92MIX - IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN - WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' - CLOSE(25) - STOP - ENDIF - - READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK - WRITE (*, *) ' nelec = ', NELEC - WRITE (*, *) ' ncftot = ', NCFTOT - WRITE (*, *) ' nw = ', NW - WRITE (*, *) ' nblock = ', NBLOCK - WRITE (*, *) - + READ (25, IOSTAT=IOS) G92MIX + IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN + WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;' + CLOSE(25) + STOP + ENDIF + + READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK + WRITE (*, *) ' nelec = ', NELEC + WRITE (*, *) ' ncftot = ', NCFTOT + WRITE (*, *) ' nw = ', NW + WRITE (*, *) ' nblock = ', NBLOCK + WRITE (*, *) + !*********************************************************************** ! Allocate memory for old format data !*********************************************************************** - - CALL ALLOC (EVAL, NVECTOT, 'EVAL', name) - CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', name) - CALL ALLOC (IVEC, NVECTOT, 'IVEC', name) - CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', name ) - CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', name) - + + CALL ALLOC (EVAL, NVECTOT, 'EVAL', name) + CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', name) + CALL ALLOC (IVEC, NVECTOT, 'IVEC', name) + CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', name ) + CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', name) + !*********************************************************************** ! Initialize mixing coefficients to zero; others are fine !*********************************************************************** - EVEC(:NVECTOT*NCFTOT) = 0.D0 - + EVEC(:NVECTOT*NCFTOT) = 0.D0 + !*********************************************************************** ! Initialize counters and sum registers ! @@ -104,62 +104,62 @@ SUBROUTINE GETMIXBLOCK(NAME, NCI) ! at least one eigenstate is calculated ! neavsum: total number CSF contributing to eavsum !*********************************************************************** - - NVECPAT = 0 - NCFPAT = 0 - NVECSIZPAT = 0 - NEAVSUM = 0 - EAVSUM = 0.D0 - - WRITE (*, *) ' block ncf nev 2j+1 parity' - DO JB = 1, NBLOCK - - READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA - WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA - IF (JB /= NB) STOP 'jb .NE. nb' - - IF (NEVBLK > 0) THEN - - READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) + + NVECPAT = 0 + NCFPAT = 0 + NVECSIZPAT = 0 + NEAVSUM = 0 + EAVSUM = 0.D0 + + WRITE (*, *) ' block ncf nev 2j+1 parity' + DO JB = 1, NBLOCK + + READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA + WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA + IF (JB /= NB) STOP 'jb .NE. nb' + + IF (NEVBLK > 0) THEN + + READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK) ! ivec(i) = ivec(i) + ncfpat ! serial # of the state - IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP - IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA - - READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) - + IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP + IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA + + READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK) + ! ...Construct the true energy by adding up the average EVAL(NVECPAT+1:NEVBLK+NVECPAT) = EVAL(NVECPAT+1:NEVBLK+NVECPAT) + & - EAV + EAV ! ...For overal (all blocks) average energy - EAVSUM = EAVSUM + EAV*NCFBLK - NEAVSUM = NEAVSUM + NCFBLK - + EAVSUM = EAVSUM + EAV*NCFBLK + NEAVSUM = NEAVSUM + NCFBLK + READ (25) ((EVEC(NVECSIZPAT+NCFPAT+I+(J-1)*NCFTOT),I=1,NCFBLK),J=1,& - NEVBLK) - ENDIF - - NVECPAT = NVECPAT + NEVBLK - NCFPAT = NCFPAT + NCFBLK - NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT - - END DO - + NEVBLK) + ENDIF + + NVECPAT = NVECPAT + NEVBLK + NCFPAT = NCFPAT + NCFBLK + NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT + + END DO + ! ...Here eav is the average energy of the blocks where at least ! one eigenstate is calculated. It is not the averge of the ! total Hamiltonian. - - EAV = EAVSUM/NEAVSUM - + + EAV = EAVSUM/NEAVSUM + IF (NCFTOT /= NEAVSUM) WRITE (6, *) & - 'Not all blocks are diagonalized --- Average E ', 'not correct' - + 'Not all blocks are diagonalized --- Average E ', 'not correct' + ! ...Substrct the overal average energy - EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV - - CLOSE(25) - - NCF = NCFTOT - NVEC = NVECTOT - - RETURN - END SUBROUTINE GETMIXBLOCK + EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV + + CLOSE(25) + + NCF = NCFTOT + NVEC = NVECTOT + + RETURN + END SUBROUTINE GETMIXBLOCK diff --git a/src/appl/sms90/getmixblock_I.f90 b/src/appl/sms90/getmixblock_I.f90 index 3956b6b72..cc8dcb9a7 100644 --- a/src/appl/sms90/getmixblock_I.f90 +++ b/src/appl/sms90/getmixblock_I.f90 @@ -1,11 +1,11 @@ - MODULE getmixblock_I + MODULE getmixblock_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:44:59 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:44:59 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE getmixblock (NAME, NCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getmixblock (NAME, NCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/getsmd.f90 b/src/appl/sms90/getsmd.f90 index b9c24c807..9f94d0aff 100644 --- a/src/appl/sms90/getsmd.f90 +++ b/src/appl/sms90/getsmd.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETSMD(NAME) + SUBROUTINE GETSMD(NAME) ! * ! Interactively determines the data governing the SMS problem. * ! * @@ -10,13 +10,13 @@ SUBROUTINE GETSMD(NAME) ! Written by Farid A. Parpia Last revision: 15 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE decide_C USE def_C @@ -31,121 +31,121 @@ SUBROUTINE GETSMD(NAME) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setiso_I - USE setqic_I - USE radgrd_I - USE nucpot_I - USE setrwfa_I + USE getyn_I + USE setiso_I + USE setqic_I + USE radgrd_I + USE nucpot_I + USE setrwfa_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER, INTENT(IN) :: NAME*24 + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - LOGICAL :: YES + LOGICAL :: YES !----------------------------------------------- ! ! ! Open, check, load data from, and close the .iso file ! - CALL SETISO ('isodata') + CALL SETISO ('isodata') ! ! Determine the physical effects specifications ! - - IF (NDEF /= 0) THEN - WRITE (6, *) 'The physical speed of light in' - WRITE (6, *) ' atomic units is', CVAC, ';' - WRITE (6, *) ' revise this value?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter the revised value:' - READ (5, *) C - ELSE - C = CVAC - ENDIF - ELSE - C = CVAC - ENDIF -! - IF (NDEF /= 0) THEN -! - WRITE (6, *) 'Treat contributions of some CSFs' - WRITE (6, *) ' as first-order perturbations?' - YES = GETYN() - IF (YES) THEN - LFORDR = .TRUE. - WRITE (6, *) 'The contribution of CSFs' - WRITE (6, *) ' 1 -- ICCUT will be treated' - WRITE (6, *) ' variationally; the remainder' - WRITE (6, *) ' perturbatively; enter ICCUT:' - READ (5, *) ICCUT - ELSE - LFORDR = .FALSE. - ICCUT = 0 - ENDIF - ELSE - LFORDR = .FALSE. - ICCUT = 0 - ENDIF + + IF (NDEF /= 0) THEN + WRITE (6, *) 'The physical speed of light in' + WRITE (6, *) ' atomic units is', CVAC, ';' + WRITE (6, *) ' revise this value?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter the revised value:' + READ (5, *) C + ELSE + C = CVAC + ENDIF + ELSE + C = CVAC + ENDIF +! + IF (NDEF /= 0) THEN +! + WRITE (6, *) 'Treat contributions of some CSFs' + WRITE (6, *) ' as first-order perturbations?' + YES = GETYN() + IF (YES) THEN + LFORDR = .TRUE. + WRITE (6, *) 'The contribution of CSFs' + WRITE (6, *) ' 1 -- ICCUT will be treated' + WRITE (6, *) ' variationally; the remainder' + WRITE (6, *) ' perturbatively; enter ICCUT:' + READ (5, *) ICCUT + ELSE + LFORDR = .FALSE. + ICCUT = 0 + ENDIF + ELSE + LFORDR = .FALSE. + ICCUT = 0 + ENDIF ! ! Determine the parameters controlling the radial grid ! - IF (NPARM == 0) THEN - RNT = EXP((-65.0D00/16.0D00))/Z - H = 0.5D00**4 - N = MIN(220,NNNP) - ELSE + IF (NPARM == 0) THEN + RNT = EXP((-65.0D00/16.0D00))/Z + H = 0.5D00**4 + N = MIN(220,NNNP) + ELSE !CFF .. should be Z-dependent - RNT = 2.0D-06/Z - H = 5.0D-02 - N = NNNP - ENDIF - HP = 0.0D00 - IF (NDEF /= 0) THEN - WRITE (6, *) 'The default radial grid parameters' - WRITE (6, *) ' for this case are:' - WRITE (6, *) ' RNT = ', RNT, ';' - WRITE (6, *) ' H = ', H, ';' - WRITE (6, *) ' HP = ', HP, ';' - WRITE (6, *) ' N = ', N, ';' - WRITE (6, *) ' revise these values?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) 'Enter RNT:' - READ (5, *) RNT - WRITE (6, *) 'Enter H:' - READ (5, *) H - WRITE (6, *) 'Enter HP:' - READ (5, *) HP - WRITE (6, *) 'Enter N:' - READ (5, *) N - ENDIF - ENDIF + RNT = 2.0D-06/Z + H = 5.0D-02 + N = NNNP + ENDIF + HP = 0.0D00 + IF (NDEF /= 0) THEN + WRITE (6, *) 'The default radial grid parameters' + WRITE (6, *) ' for this case are:' + WRITE (6, *) ' RNT = ', RNT, ';' + WRITE (6, *) ' H = ', H, ';' + WRITE (6, *) ' HP = ', HP, ';' + WRITE (6, *) ' N = ', N, ';' + WRITE (6, *) ' revise these values?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) 'Enter RNT:' + READ (5, *) RNT + WRITE (6, *) 'Enter H:' + READ (5, *) H + WRITE (6, *) 'Enter HP:' + READ (5, *) HP + WRITE (6, *) 'Enter N:' + READ (5, *) N + ENDIF + ENDIF ! ! ACCY is an estimate of the accuracy of the numerical procedures ! - ACCY = H**6 + ACCY = H**6 ! ! Set up the coefficients for the numerical procedures ! - CALL SETQIC + CALL SETQIC ! ! Generate the radial grid and all associated arrays ! - CALL RADGRD + CALL RADGRD ! ! Generate $- r \times V_nuc (r)$ ! - CALL NUCPOT + CALL NUCPOT ! ! Load the radial wavefunctions ! ! CALL SETRWFA(NAME) - CALL SETRWFA (TRIM(NAME)//'.w') + CALL SETRWFA (TRIM(NAME)//'.w') ! - RETURN - END SUBROUTINE GETSMD + RETURN + END SUBROUTINE GETSMD diff --git a/src/appl/sms90/getsmd_I.f90 b/src/appl/sms90/getsmd_I.f90 index 1d9249691..59593bd64 100644 --- a/src/appl/sms90/getsmd_I.f90 +++ b/src/appl/sms90/getsmd_I.f90 @@ -1,10 +1,10 @@ - MODULE getsmd_I + MODULE getsmd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE getsmd (NAME) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE getsmd (NAME) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/polint.f90 b/src/appl/sms90/polint.f90 index 7fb376c45..547014130 100644 --- a/src/appl/sms90/polint.f90 +++ b/src/appl/sms90/polint.f90 @@ -1,67 +1,67 @@ !************************************************************************ ! - SUBROUTINE POLINT(XA, YA, N, X, Y, DY) + SUBROUTINE POLINT(XA, YA, N, X, Y, DY) !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: X REAL(DOUBLE), INTENT(OUT) :: Y, DY - REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: XA, YA + REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: XA, YA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NMAX = 10 + INTEGER, PARAMETER :: NMAX = 10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NS, I, M - REAL(DOUBLE), DIMENSION(NMAX) :: C, D + INTEGER :: NS, I, M + REAL(DOUBLE), DIMENSION(NMAX) :: C, D REAL(DOUBLE) :: DIF, DIFT, HO, HP, W, DEN !----------------------------------------------- - NS = 1 - DIF = ABS(X - XA(1)) - DO I = 1, N - DIFT = ABS(X - XA(I)) - IF (DIFT < DIF) THEN - NS = I - DIF = DIFT - ENDIF - C(I) = YA(I) - D(I) = YA(I) - END DO - Y = YA(NS) - NS = NS - 1 - DO M = 1, N - 1 - DO I = 1, N - M - HO = XA(I) - X - HP = XA(I+M) - X - W = C(I+1) - D(I) - DEN = HO - HP - IF (DEN == 0.0D00) THEN - WRITE (*, '(2A)') 'PAUSE ', 'FAILURE IN POLINT' - READ * - ENDIF - DEN = W/DEN - D(I) = HP*DEN - C(I) = HO*DEN - END DO - IF (2*NS < N - M) THEN - DY = C(NS+1) - ELSE - DY = D(NS) - NS = NS - 1 - ENDIF - Y = Y + DY - END DO - RETURN - END SUBROUTINE POLINT + NS = 1 + DIF = ABS(X - XA(1)) + DO I = 1, N + DIFT = ABS(X - XA(I)) + IF (DIFT < DIF) THEN + NS = I + DIF = DIFT + ENDIF + C(I) = YA(I) + D(I) = YA(I) + END DO + Y = YA(NS) + NS = NS - 1 + DO M = 1, N - 1 + DO I = 1, N - M + HO = XA(I) - X + HP = XA(I+M) - X + W = C(I+1) - D(I) + DEN = HO - HP + IF (DEN == 0.0D00) THEN + WRITE (*, '(2A)') 'PAUSE ', 'FAILURE IN POLINT' + READ * + ENDIF + DEN = W/DEN + D(I) = HP*DEN + C(I) = HO*DEN + END DO + IF (2*NS < N - M) THEN + DY = C(NS+1) + ELSE + DY = D(NS) + NS = NS - 1 + ENDIF + Y = Y + DY + END DO + RETURN + END SUBROUTINE POLINT diff --git a/src/appl/sms90/polint_I.f90 b/src/appl/sms90/polint_I.f90 index e4cdbfcd6..2c1442e86 100644 --- a/src/appl/sms90/polint_I.f90 +++ b/src/appl/sms90/polint_I.f90 @@ -1,16 +1,16 @@ - MODULE polint_I + MODULE polint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE polint (XA, YA, N, X, Y, DY) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: XA - REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: YA - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: X - REAL(DOUBLE), INTENT(OUT) :: Y - REAL(DOUBLE), INTENT(OUT) :: DY - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE polint (XA, YA, N, X, Y, DY) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: XA + REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: YA + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: X + REAL(DOUBLE), INTENT(OUT) :: Y + REAL(DOUBLE), INTENT(OUT) :: DY + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/rintdens.f90 b/src/appl/sms90/rintdens.f90 index adc1343bd..eee9ea714 100644 --- a/src/appl/sms90/rintdens.f90 +++ b/src/appl/sms90/rintdens.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTDENS (I, J) + REAL(KIND(0.0D0)) FUNCTION RINTDENS (I, J) ! * ! The value of RINTDENS is an approximation to: * ! * @@ -13,39 +13,39 @@ REAL(KIND(0.0D0)) FUNCTION RINTDENS (I, J) ! Written by Per Jonsson Last revision: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE def_C, ONLY: cvac, pi USE grid_C USE wave_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE polint_I + USE polint_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE), DIMENSION(3) :: XA, YA - REAL(DOUBLE) :: DENS, DDENS + INTEGER :: L + REAL(DOUBLE), DIMENSION(3) :: XA, YA + REAL(DOUBLE) :: DENS, DDENS !----------------------------------------------- ! - DO L = 4, 2, -1 - XA(L-1) = R(L) - YA(L-1) = (PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))/(4.0D00*PI*R(L)*R(L)) - END DO - CALL POLINT (XA, YA, 3, 0.0D00, DENS, DDENS) - RINTDENS = DENS + DO L = 4, 2, -1 + XA(L-1) = R(L) + YA(L-1) = (PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))/(4.0D00*PI*R(L)*R(L)) + END DO + CALL POLINT (XA, YA, 3, 0.0D00, DENS, DDENS) + RINTDENS = DENS ! - RETURN - END FUNCTION RINTDENS + RETURN + END FUNCTION RINTDENS diff --git a/src/appl/sms90/rintdens_I.f90 b/src/appl/sms90/rintdens_I.f90 index 13702cae9..dbf337547 100644 --- a/src/appl/sms90/rintdens_I.f90 +++ b/src/appl/sms90/rintdens_I.f90 @@ -1,11 +1,11 @@ - MODULE rintdens_I + MODULE rintdens_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - REAL(KIND(0.0D0)) FUNCTION rintdens (I, J) - INTEGER :: I - INTEGER :: J - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintdens (I, J) + INTEGER :: I + INTEGER :: J + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/sms90/rintiso.f90 b/src/appl/sms90/rintiso.f90 index b0b4a7167..0c19bc0bc 100644 --- a/src/appl/sms90/rintiso.f90 +++ b/src/appl/sms90/rintiso.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTISO (I, J) + REAL(KIND(0.0D0)) FUNCTION RINTISO (I, J) ! * ! The value of RINTISO is an approximation to: * ! * @@ -17,13 +17,13 @@ REAL(KIND(0.0D0)) FUNCTION RINTISO (I, J) ! Written by Per Jonsson Last revision: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE grid_C USE dvpot_C USE tatb_C @@ -31,34 +31,34 @@ REAL(KIND(0.0D0)) FUNCTION RINTISO (I, J) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I, J + INTEGER :: I, J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! Tabulate integrand as required for SUBROUTINE QUAD ! - MTP = MIN(MF(I),MF(J)) + MTP = MIN(MF(I),MF(J)) ! ! Value at first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = DV(L)*(PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = DV(L)*(PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))*RP(L) + END DO ! ! Perform integration ! - CALL QUAD (RESULT) - RINTISO = RESULT + CALL QUAD (RESULT) + RINTISO = RESULT ! - RETURN - END FUNCTION RINTISO + RETURN + END FUNCTION RINTISO diff --git a/src/appl/sms90/rintiso_I.f90 b/src/appl/sms90/rintiso_I.f90 index 7cce9c773..3bcca7cea 100644 --- a/src/appl/sms90/rintiso_I.f90 +++ b/src/appl/sms90/rintiso_I.f90 @@ -1,11 +1,11 @@ - MODULE rintiso_I + MODULE rintiso_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - REAL(KIND(0.0D0)) FUNCTION rintiso (I, J) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rintiso (I, J) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/sms90/setdbg.f90 b/src/appl/sms90/setdbg.f90 index 375b8d4a4..3985c84d0 100644 --- a/src/appl/sms90/setdbg.f90 +++ b/src/appl/sms90/setdbg.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETDBG + SUBROUTINE SETDBG ! * ! This subroutine sets the arrays that control debug printout from * ! the radial and angular modules of the GRASP92 suite. * @@ -10,8 +10,8 @@ SUBROUTINE SETDBG ! Written by Farid A Parpia Last update: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- ! M o d u l e s @@ -21,95 +21,95 @@ SUBROUTINE SETDBG !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE openfl_I + USE getyn_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IERR - LOGICAL :: YES - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: I, IERR + LOGICAL :: YES + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 ! ! Initialise the arrays that control the debug printout ! - LDBPA = .FALSE. + LDBPA = .FALSE. ! - LDBPG = .FALSE. + LDBPG = .FALSE. ! - LDBPR = .FALSE. + LDBPR = .FALSE. ! - IF (NDEF == 0) RETURN - - WRITE (6, *) 'Generate debug printout?' - YES = GETYN() - IF (YES) THEN + IF (NDEF == 0) RETURN + + WRITE (6, *) 'Generate debug printout?' + YES = GETYN() + IF (YES) THEN ! ! The .dbg file is formatted; open it on unit 99 ! - DEFNAM = 'sms92.dbg' - FORM = 'FORMATTED' - STATUS = 'NEW' -! - WRITE (6, *) 'File sms92.dbg will be created as the' - WRITE (6, *) ' SMS92 DeBuG Printout File; enter another' - WRITE (6, *) ' file name if this is not acceptable;' - WRITE (6, *) ' null otherwise:' - READ (*, '(A)') FILNAM -! - IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM -! - 4 CONTINUE - CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - 5 CONTINUE - WRITE (6, *) 'Enter a name for the SMS92 DeBuG Printout' - WRITE (6, *) ' file that is to be created:' - READ (*, '(A)') FILNAM - IF (LEN_TRIM(FILNAM) == 0) GO TO 5 - GO TO 4 - ENDIF + DEFNAM = 'sms92.dbg' + FORM = 'FORMATTED' + STATUS = 'NEW' +! + WRITE (6, *) 'File sms92.dbg will be created as the' + WRITE (6, *) ' SMS92 DeBuG Printout File; enter another' + WRITE (6, *) ' file name if this is not acceptable;' + WRITE (6, *) ' null otherwise:' + READ (*, '(A)') FILNAM +! + IF (LEN_TRIM(FILNAM) == 0) FILNAM = DEFNAM +! + 4 CONTINUE + CALL OPENFL (99, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + 5 CONTINUE + WRITE (6, *) 'Enter a name for the SMS92 DeBuG Printout' + WRITE (6, *) ' file that is to be created:' + READ (*, '(A)') FILNAM + IF (LEN_TRIM(FILNAM) == 0) GO TO 5 + GO TO 4 + ENDIF ! ! Set options for general printout ! - WRITE (6, *) ' Print out the machine constants used?' - YES = GETYN() - IF (YES) LDBPG(1) = .TRUE. - WRITE (6, *) ' Print out the physical constants used?' - YES = GETYN() - IF (YES) LDBPG(2) = .TRUE. + WRITE (6, *) ' Print out the machine constants used?' + YES = GETYN() + IF (YES) LDBPG(1) = .TRUE. + WRITE (6, *) ' Print out the physical constants used?' + YES = GETYN() + IF (YES) LDBPG(2) = .TRUE. ! ! Set options for radial modules ! - WRITE (6, *) ' Printout from radial modules?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) ' Printout from RADGRD?' - YES = GETYN() - IF (YES) LDBPR(1) = .TRUE. - WRITE (6, *) ' Printout from NUCPOT?' - YES = GETYN() - IF (YES) LDBPR(2) = .TRUE. - WRITE (6, *) ' Printout from LODRWF?' - YES = GETYN() - IF (YES) LDBPR(3) = .TRUE. -! - ENDIF + WRITE (6, *) ' Printout from radial modules?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) ' Printout from RADGRD?' + YES = GETYN() + IF (YES) LDBPR(1) = .TRUE. + WRITE (6, *) ' Printout from NUCPOT?' + YES = GETYN() + IF (YES) LDBPR(2) = .TRUE. + WRITE (6, *) ' Printout from LODRWF?' + YES = GETYN() + IF (YES) LDBPR(3) = .TRUE. +! + ENDIF ! ! Set options for angular modules ! - WRITE (6, *) ' Printout from angular modules?' - YES = GETYN() - IF (YES) THEN - WRITE (6, *) ' Printout from LODCSL?' - YES = GETYN() - IF (YES) LDBPA(1) = .TRUE. - WRITE (6, *) ' Print out V coefficients?' - YES = GETYN() - IF (YES) LDBPA(2) = .TRUE. - ENDIF -! - ENDIF -! - RETURN - END SUBROUTINE SETDBG + WRITE (6, *) ' Printout from angular modules?' + YES = GETYN() + IF (YES) THEN + WRITE (6, *) ' Printout from LODCSL?' + YES = GETYN() + IF (YES) LDBPA(1) = .TRUE. + WRITE (6, *) ' Print out V coefficients?' + YES = GETYN() + IF (YES) LDBPA(2) = .TRUE. + ENDIF +! + ENDIF +! + RETURN + END SUBROUTINE SETDBG diff --git a/src/appl/sms90/setdbg_I.f90 b/src/appl/sms90/setdbg_I.f90 index 6b1328a4a..1920e9fa4 100644 --- a/src/appl/sms90/setdbg_I.f90 +++ b/src/appl/sms90/setdbg_I.f90 @@ -1,9 +1,9 @@ - MODULE setdbg_I + MODULE setdbg_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE setdbg - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setdbg + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/setmcp.f90 b/src/appl/sms90/setmcp.f90 index 62fa59650..eaec62c63 100644 --- a/src/appl/sms90/setmcp.f90 +++ b/src/appl/sms90/setmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETMCP(AVAIL) + SUBROUTINE SETMCP(AVAIL) ! * ! Open and check the .mcp files. File 30 stores the structure of * ! H(DC) ; file 31 stores the T coefficients; files 32, 33, ..., * @@ -11,11 +11,11 @@ SUBROUTINE SETMCP(AVAIL) ! Written by Farid A. Parpia Last revision: 19 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE def_C USE iccu_C @@ -24,94 +24,94 @@ SUBROUTINE SETMCP(AVAIL) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE openfl_I + USE convrt_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - LOGICAL, INTENT(OUT) :: AVAIL + LOGICAL, INTENT(OUT) :: AVAIL !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, LCK, LFN, IERR, IOS, NELECT, NCFT, NWT, ICCUTT, I - LOGICAL :: DIAGT, FOUND, FOUND1, LFORDT + INTEGER :: K, LCK, LFN, IERR, IOS, NELECT, NCFT, NWT, ICCUTT, I + LOGICAL :: DIAGT, FOUND, FOUND1, LFORDT CHARACTER :: FILNAM*256, FULNAM*256, DEFNAM*3, FORM*11, SRTLAB*8, MCPLAB& - *3, STATUS*3, CK*2 + *3, STATUS*3, CK*2 !----------------------------------------------- ! ! Determine KMAXF; this is one less than the number of .mcp ! files for the two-electron integrals ! - AVAIL = .TRUE. - KMAXF = 0 - DO K = 1, NW - KMAXF = MAX(KMAXF,NKJ(K)) - END DO + AVAIL = .TRUE. + KMAXF = 0 + DO K = 1, NW + KMAXF = MAX(KMAXF,NKJ(K)) + END DO ! ! All files grasp92.mcp.xx are UNFORMATTED; they must exist ! - FORM = 'UNFORMATTED' - DEFNAM = 'mcp' - STATUS = 'OLD' + FORM = 'UNFORMATTED' + DEFNAM = 'mcp' + STATUS = 'OLD' ! ! Look for grasp92.mcp.30 , ... ! - FOUND = .TRUE. - DO K = 30, 32 + KMAXF - CALL CONVRT (K, CK, LCK) - INQUIRE(FILE=DEFNAM//'.'//CK(1:2), EXIST=FOUND1) - FOUND = FOUND .AND. FOUND1 - END DO + FOUND = .TRUE. + DO K = 30, 32 + KMAXF + CALL CONVRT (K, CK, LCK) + INQUIRE(FILE=DEFNAM//'.'//CK(1:2), EXIST=FOUND1) + FOUND = FOUND .AND. FOUND1 + END DO ! - IF (FOUND) THEN - FILNAM = DEFNAM - ELSE - WRITE (6, *) 'The mcp files does not exist' - AVAIL = .FALSE. - RETURN - ENDIF + IF (FOUND) THEN + FILNAM = DEFNAM + ELSE + WRITE (6, *) 'The mcp files does not exist' + AVAIL = .FALSE. + RETURN + ENDIF ! ! Open the files; check file headers ! - LFN = LEN_TRIM(FILNAM) - DO K = 30, 32 + KMAXF - CALL CONVRT (K, CK, LCK) - FULNAM = FILNAM(1:LFN)//'.'//CK(1:2) - CALL OPENFL (K, FULNAM, FORM, STATUS, IERR) - IF (IERR == 0) THEN - READ (K, IOSTAT=IOS) MCPLAB, SRTLAB - IF (IOS/=0 .OR. MCPLAB/='MCP' .OR. SRTLAB/=' SORTED') THEN - WRITE (6, *) 'Not a sorted GRASP92 MCP File;' - IERR = IERR + 1 - ENDIF - ENDIF - IF (IERR == 0) THEN - READ (K) NELECT, NCFT, NWT - IF (NELECT/=NELEC .OR. NCFT/=NCF .OR. NWT/=NW) THEN - WRITE (6, *) 'Sorted GRASP92 MCP File not appropriate' - WRITE (6, *) ' to Configuration Symmetry List;' - IERR = IERR + 1 - ENDIF - IF (K == 30) THEN - READ (K) DIAG, ICCUT(1), LFORDR - ELSE - READ (K) DIAGT, ICCUTT, LFORDT + LFN = LEN_TRIM(FILNAM) + DO K = 30, 32 + KMAXF + CALL CONVRT (K, CK, LCK) + FULNAM = FILNAM(1:LFN)//'.'//CK(1:2) + CALL OPENFL (K, FULNAM, FORM, STATUS, IERR) + IF (IERR == 0) THEN + READ (K, IOSTAT=IOS) MCPLAB, SRTLAB + IF (IOS/=0 .OR. MCPLAB/='MCP' .OR. SRTLAB/=' SORTED') THEN + WRITE (6, *) 'Not a sorted GRASP92 MCP File;' + IERR = IERR + 1 + ENDIF + ENDIF + IF (IERR == 0) THEN + READ (K) NELECT, NCFT, NWT + IF (NELECT/=NELEC .OR. NCFT/=NCF .OR. NWT/=NW) THEN + WRITE (6, *) 'Sorted GRASP92 MCP File not appropriate' + WRITE (6, *) ' to Configuration Symmetry List;' + IERR = IERR + 1 + ENDIF + IF (K == 30) THEN + READ (K) DIAG, ICCUT(1), LFORDR + ELSE + READ (K) DIAGT, ICCUTT, LFORDT IF ((DIAGT .NEQV. DIAG) .OR. ICCUTT/=ICCUT(1) .OR. (LFORDT .NEQV. & - LFORDR)) THEN - WRITE (6, *) 'Sorted GRASP92 MCP Files are not' - WRITE (6, *) ' consistent;' - IERR = IERR + 1 - ENDIF - ENDIF - ENDIF - IF (IERR == 0) CYCLE - DO I = 30, K - CLOSE(I) - END DO - AVAIL = .FALSE. - RETURN - END DO + LFORDR)) THEN + WRITE (6, *) 'Sorted GRASP92 MCP Files are not' + WRITE (6, *) ' consistent;' + IERR = IERR + 1 + ENDIF + ENDIF + ENDIF + IF (IERR == 0) CYCLE + DO I = 30, K + CLOSE(I) + END DO + AVAIL = .FALSE. + RETURN + END DO ! - RETURN - END SUBROUTINE SETMCP + RETURN + END SUBROUTINE SETMCP diff --git a/src/appl/sms90/setmcp_I.f90 b/src/appl/sms90/setmcp_I.f90 index 802f6f491..c9d4d245a 100644 --- a/src/appl/sms90/setmcp_I.f90 +++ b/src/appl/sms90/setmcp_I.f90 @@ -1,10 +1,10 @@ - MODULE setmcp_I + MODULE setmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE setmcp (AVAIL) - LOGICAL, INTENT(OUT) :: AVAIL - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setmcp (AVAIL) + LOGICAL, INTENT(OUT) :: AVAIL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/setsum.f90 b/src/appl/sms90/setsum.f90 index 9393f698f..f378808b1 100644 --- a/src/appl/sms90/setsum.f90 +++ b/src/appl/sms90/setsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETSUM(NAME, NCI) + SUBROUTINE SETSUM(NAME, NCI) ! * ! Open the .sum file on stream 24. * ! * @@ -9,46 +9,46 @@ SUBROUTINE SETSUM(NAME, NCI) ! Written by Farid A. Parpia Last revision: 24 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCI - CHARACTER, INTENT(IN) :: NAME*24 + INTEGER, INTENT(IN) :: NCI + CHARACTER, INTENT(IN) :: NAME*24 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR - CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 + INTEGER :: K, IERR + CHARACTER :: FILNAM*256, DEFNAM*11, FORM*11, STATUS*3 !----------------------------------------------- ! ! File sms92.sum is FORMATTED ! - K = INDEX(NAME,' ') - IF (NCI == 0) THEN - FILNAM = NAME(1:K-1)//'.ci' - ELSE - FILNAM = NAME(1:K-1)//'.i' - ENDIF - FORM = 'FORMATTED' - STATUS = 'NEW' + K = INDEX(NAME,' ') + IF (NCI == 0) THEN + FILNAM = NAME(1:K-1)//'.ci' + ELSE + FILNAM = NAME(1:K-1)//'.i' + ENDIF + FORM = 'FORMATTED' + STATUS = 'NEW' ! - CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (6, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (24, FILNAM, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (6, *) 'Error when opening', FILNAM + STOP + ENDIF ! - RETURN - END SUBROUTINE SETSUM + RETURN + END SUBROUTINE SETSUM diff --git a/src/appl/sms90/setsum_I.f90 b/src/appl/sms90/setsum_I.f90 index fd8444e84..ad1a3476a 100644 --- a/src/appl/sms90/setsum_I.f90 +++ b/src/appl/sms90/setsum_I.f90 @@ -1,11 +1,11 @@ - MODULE setsum_I + MODULE setsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE setsum (NAME, NCI) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER, INTENT(IN) :: NCI - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE setsum (NAME, NCI) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER, INTENT(IN) :: NCI + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/sms.f90 b/src/appl/sms90/sms.f90 index 85d6dd1c2..78fadc9d8 100644 --- a/src/appl/sms90/sms.f90 +++ b/src/appl/sms90/sms.f90 @@ -15,10 +15,10 @@ SUBROUTINE SMS ! Last revision: 10 Nov 1995 * ! * !*********************************************************************** -!...Created by Charlotte Froese Fischer +!...Created by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW @@ -77,7 +77,7 @@ SUBROUTINE SMS DENS5(I) = 0.0D00 DENS6(I) = 0.0D00 ENDDO - + VSH = .TRUE. SMSSH = .TRUE. ! @@ -203,7 +203,7 @@ SUBROUTINE SMS //' Level J Parity',8X,' (a.u.)'/) 312 FORMAT (//' Radial expectationvalue' & //' Level J Parity',8X,' (a.u.)'/) - + ! RETURN END SUBROUTINE SMS diff --git a/src/appl/sms90/sms1_C.f90 b/src/appl/sms90/sms1_C.f90 index 05bbb9ddc..659e1031c 100644 --- a/src/appl/sms90/sms1_C.f90 +++ b/src/appl/sms90/sms1_C.f90 @@ -1,8 +1,8 @@ - MODULE sms1_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE sms1_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 18:41:20 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 REAL(DOUBLE), DIMENSION(:), pointer :: DENS1, DENS2, DENS3, & DENS4, DENS5, DENS6, SMSC - END MODULE sms1_C + END MODULE sms1_C diff --git a/src/appl/sms90/sms92.f90 b/src/appl/sms90/sms92.f90 index 564dc0b7e..a4d15f3f1 100644 --- a/src/appl/sms90/sms92.f90 +++ b/src/appl/sms90/sms92.f90 @@ -32,7 +32,7 @@ !*********************************************************************** !*********************************************************************** ! * - PROGRAM SMS92 + PROGRAM SMS92 ! * ! Entry routine for SMS92. Controls the entire computation. * ! * @@ -46,130 +46,130 @@ PROGRAM SMS92 ! Last revision: Nov 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Switches: +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Switches: !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE getyn_I - USE setdbg_I - USE setmc_I - USE setcon_I - USE setsum_I - USE setcsla_I - USE getsmd_I - USE getmixblock_I - USE strsum_I - USE factt_I + USE getyn_I + USE setdbg_I + USE setmc_I + USE setcon_I + USE setsum_I + USE setcsla_I + USE getsmd_I + USE getmixblock_I + USE strsum_I + USE factt_I USE sms_I IMPLICIT NONE !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- -!... /DEFAULT/ - COMMON /DEFAULT/ NDEF - INTEGER NDEF +!... /DEFAULT/ + COMMON /DEFAULT/ NDEF + INTEGER NDEF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, NCI, NCORE_NOT_USED - LOGICAL :: YES - CHARACTER :: NAME*24 + INTEGER :: K, NCI, NCORE_NOT_USED + LOGICAL :: YES + CHARACTER :: NAME*24 !----------------------------------------------- ! WRITE (6, *) WRITE (6, *) 'RSMS' WRITE (6, *) 'This is the isotope shift program' WRITE (6, *) 'Input files: isodata, name.c, name.(c)m, name.w' - WRITE (6, *) 'Output files: name.(c)i' + WRITE (6, *) 'Output files: name.(c)i' - WRITE (6, *) - WRITE (6, *) 'Default settings?' - YES = GETYN() - WRITE (6, *) - IF (YES) THEN - NDEF = 0 - ELSE - NDEF = 1 - ENDIF - - 10 CONTINUE - WRITE (6, *) 'Name of state' - READ (*, '(A)') NAME - K = INDEX(NAME,' ') - IF (K == 1) THEN - WRITE (6, *) 'Names may not start with a blank' - GO TO 10 - ENDIF - WRITE (6, *) - WRITE (6, *) 'Mixing coefficients from a CI calc.?' - YES = GETYN() - IF (YES) THEN - NCI = 0 - ELSE - NCI = 1 - ENDIF + WRITE (6, *) + WRITE (6, *) 'Default settings?' + YES = GETYN() + WRITE (6, *) + IF (YES) THEN + NDEF = 0 + ELSE + NDEF = 1 + ENDIF + + 10 CONTINUE + WRITE (6, *) 'Name of state' + READ (*, '(A)') NAME + K = INDEX(NAME,' ') + IF (K == 1) THEN + WRITE (6, *) 'Names may not start with a blank' + GO TO 10 + ENDIF + WRITE (6, *) + WRITE (6, *) 'Mixing coefficients from a CI calc.?' + YES = GETYN() + IF (YES) THEN + NCI = 0 + ELSE + NCI = 1 + ENDIF ! ! Check compatibility of plant substitutions ! -!GG CALL CHKPLT +!GG CALL CHKPLT ! ! Determine if there is to be any debug printout; this will be ! made on the .dbg file ! - CALL SETDBG + CALL SETDBG ! ! Perform machine- and installation-dependent setup ! - CALL SETMC + CALL SETMC ! ! Set up the physical constants ! - CALL SETCON + CALL SETCON ! ! Open the .sum file ! - CALL SETSUM (NAME, NCI) + CALL SETSUM (NAME, NCI) ! ! Open, check, load data from, and close, the .csl file ! - CALL SETCSLA (NAME, NCORE_NOT_USED) + CALL SETCSLA (NAME, NCORE_NOT_USED) ! ! Get the remaining information ! - CALL GETSMD (NAME) + CALL GETSMD (NAME) ! ! Get the eigenvectors ! -!GG WRITE (6, *) 'Block format?' -!GG YES = GETYN() -!GG WRITE (6, *) -!GG IF (YES) THEN - CALL GETMIXBLOCK (NAME, NCI) -!GG ELSE -!GG IF (NCI == 0) THEN -!GG CALL GETMIXC (NAME) -!GG ELSE -!GG CALL GETMIXA (NAME) -!GG ENDIF -!GG ENDIF +!GG WRITE (6, *) 'Block format?' +!GG YES = GETYN() +!GG WRITE (6, *) +!GG IF (YES) THEN + CALL GETMIXBLOCK (NAME, NCI) +!GG ELSE +!GG IF (NCI == 0) THEN +!GG CALL GETMIXC (NAME) +!GG ELSE +!GG CALL GETMIXA (NAME) +!GG ENDIF +!GG ENDIF ! ! Append a summary of the inputs to the .sum file ! - CALL STRSUM + CALL STRSUM ! ! Set up the table of logarithms of factorials ! - CALL FACTT + CALL FACTT ! ! Proceed with the SMS calculation ! - CALL SMS + CALL SMS ! ! Print completion message ! - WRITE (6, *) - WRITE (6, *) 'RSMS: Execution complete.' + WRITE (6, *) + WRITE (6, *) 'RSMS: Execution complete.' ! - STOP - END PROGRAM SMS92 + STOP + END PROGRAM SMS92 diff --git a/src/appl/sms90/sms_I.f90 b/src/appl/sms90/sms_I.f90 index 8b29fbad5..f5eeea630 100644 --- a/src/appl/sms90/sms_I.f90 +++ b/src/appl/sms90/sms_I.f90 @@ -1,9 +1,9 @@ - MODULE sms_I + MODULE sms_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:46:30 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:46:30 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE sms - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE sms + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/smsmcp.f90 b/src/appl/sms90/smsmcp.f90 index 6433f5c9d..cd8d3fe09 100644 --- a/src/appl/sms90/smsmcp.f90 +++ b/src/appl/sms90/smsmcp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SMSMCP(VINT) + SUBROUTINE SMSMCP(VINT) ! * ! This routine controls the main sequence of routine calls for the * ! calculation of the sms parameter, the electron density at the * @@ -16,13 +16,13 @@ SUBROUTINE SMSMCP(VINT) ! Last revision: 10 Nov 1995 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:46:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:46:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB, NNNW USE memory_man USE eigv_C @@ -34,194 +34,194 @@ SUBROUTINE SMSMCP(VINT) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE gco_I + USE gco_I USE vinti_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(IN) :: VINT(NNNW,NNNW) + REAL(DOUBLE), INTENT(IN) :: VINT(NNNW,NNNW) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- REAL(DOUBLE), DIMENSION(:), pointer :: COEFF INTEGER, DIMENSION(:), pointer :: ICLMN, INDEX, NSWAP INTEGER :: NDIM, I, NWM1, KM, K, IA, NKJIA, IAP1, IB, NKJIB, KMIN, KMAX, & - IR, IDIAG, NFILE, IOS, LAB, NCONTR, ID, IC, LOC, ICI, IRI, J + IR, IDIAG, NFILE, IOS, LAB, NCONTR, ID, IC, LOC, ICI, IRI, J REAL(DOUBLE) :: PCOEFF, PICLMN, PINDEX, PNSWAP, COEF, GKAB, TEGRAL, & - CONTRI - LOGICAL :: SET + CONTRI + LOGICAL :: SET !----------------------------------------------- ! OPEN(UNIT=20, FILE='sms.20', FORM='UNFORMATTED', STATUS='OLD', POSITION=& - 'asis') - + 'asis') + ! ! Allocate storage that is local to this subroutine ! - NDIM = 1 - CALL ALLOC (COEFF, NDIM,'COEFF','SMSMCP') - CALL ALLOC (ICLMN, NDIM,'ICLMN','SMSMCP') - CALL ALLOC (INDEX, NDIM,'INDEX','SMSMCP') - CALL ALLOC (NSWAP, NDIM,'NSWAP','SMSMCP') + NDIM = 1 + CALL ALLOC (COEFF, NDIM,'COEFF','SMSMCP') + CALL ALLOC (ICLMN, NDIM,'ICLMN','SMSMCP') + CALL ALLOC (INDEX, NDIM,'INDEX','SMSMCP') + CALL ALLOC (NSWAP, NDIM,'NSWAP','SMSMCP') ! ! General initializations ! - READ (30) NELMNT - CALL ALLOC (IENDC, NCF + 1,'IENDC','SMSMCP') - CALL ALLOC (IROW, NELMNT,'IROW','SMSMCP') - READ (30) (IENDC(I),I=0,NCF), (IROW(I),I=1,NELMNT) - CLOSE(30) + READ (30) NELMNT + CALL ALLOC (IENDC, NCF + 1,'IENDC','SMSMCP') + CALL ALLOC (IROW, NELMNT,'IROW','SMSMCP') + READ (30) (IENDC(I),I=0,NCF), (IROW(I),I=1,NELMNT) + CLOSE(30) ! ! Other initializations ! - CALL ALLOC (EMT, NELMNT,'EMT','SMSMCP') + CALL ALLOC (EMT, NELMNT,'EMT','SMSMCP') ! - NWM1 = NW - 1 + NWM1 = NW - 1 ! - EMT(:NELMNT) = 0.0D00 + EMT(:NELMNT) = 0.0D00 ! ! Accumulate diagonal terms that do not require MCP coefficients ! ! k ! Piece involving G (a,b) integrals ! - KM = 0 - K = 1 - DO IA = 1, NWM1 - NKJIA = NKJ(IA) - IAP1 = IA + 1 - DO IB = IAP1, NW - NKJIB = NKJ(IB) - SET = .FALSE. - IF (NAK(IA)*NAK(IB) > 0) THEN - KMIN = ABS((NKJIA - NKJIB)/2) - ELSE - KMIN = ABS((NKJIA - NKJIB)/2) + 1 - ENDIF - IF (MOD(K - KMIN,2) /= 0) CYCLE - KMAX = (NKJIA + NKJIB)/2 - KM = MAX0(KMAX,KM) - IF (KKMAX) CYCLE - DO IR = 1, NCF - COEF = GCO(K,IR,IA,IB) - IF (ABS(COEF) <= 0.0D00) CYCLE - IF (.NOT.SET) THEN + KM = 0 + K = 1 + DO IA = 1, NWM1 + NKJIA = NKJ(IA) + IAP1 = IA + 1 + DO IB = IAP1, NW + NKJIB = NKJ(IB) + SET = .FALSE. + IF (NAK(IA)*NAK(IB) > 0) THEN + KMIN = ABS((NKJIA - NKJIB)/2) + ELSE + KMIN = ABS((NKJIA - NKJIB)/2) + 1 + ENDIF + IF (MOD(K - KMIN,2) /= 0) CYCLE + KMAX = (NKJIA + NKJIB)/2 + KM = MAX0(KMAX,KM) + IF (KKMAX) CYCLE + DO IR = 1, NCF + COEF = GCO(K,IR,IA,IB) + IF (ABS(COEF) <= 0.0D00) CYCLE + IF (.NOT.SET) THEN !ww - GKAB = VINT(IA,IB)*VINT(IB,IA) + GKAB = VINT(IA,IB)*VINT(IB,IA) !ww - SET = .TRUE. - ENDIF - IDIAG = IENDC(IR - 1) + 1 - EMT(IDIAG) = EMT(IDIAG) - COEF*GKAB - END DO - END DO - END DO + SET = .TRUE. + ENDIF + IDIAG = IENDC(IR - 1) + 1 + EMT(IDIAG) = EMT(IDIAG) - COEF*GKAB + END DO + END DO + END DO ! ! Accumulate two-electron terms that require MCP coefficients ! - NFILE = 33 + NFILE = 33 ! - REWIND (NFILE) - REWIND (20) - READ (NFILE) - READ (NFILE) - READ (NFILE) + REWIND (NFILE) + REWIND (20) + READ (NFILE) + READ (NFILE) + READ (NFILE) ! ! The multipolarity of the integral can be deduced from the file ! unit number ! - K = NFILE - 32 + K = NFILE - 32 ! ! Attempt to read another block of data ! - 18 CONTINUE - READ (NFILE, IOSTAT=IOS) LAB, NCONTR + 18 CONTINUE + READ (NFILE, IOSTAT=IOS) LAB, NCONTR ! - IF (IOS == 0) THEN + IF (IOS == 0) THEN ! k ! Read successful; decode the labels of R (abcd) ! - ID = MOD(LAB,KEY) - LAB = LAB/KEY - IB = MOD(LAB,KEY) - LAB = LAB/KEY - IC = MOD(LAB,KEY) - IA = LAB/KEY + ID = MOD(LAB,KEY) + LAB = LAB/KEY + IB = MOD(LAB,KEY) + LAB = LAB/KEY + IC = MOD(LAB,KEY) + IA = LAB/KEY ! ! Compute the Vinti integrals ! !ww !ww TEGRAL = VINT (IA,IB)*VINT (IC,ID) - TEGRAL = VINT(IA,IC)*VINT(IB,ID) + TEGRAL = VINT(IA,IC)*VINT(IB,ID) !ww ! ! Ensure that storage is adequate to read in the rest of ! this block ! - IF (NCONTR > NDIM) THEN - CALL DALLOC (COEFF,'COEFF','SMSMCP') - CALL DALLOC (ICLMN,'ICLMN','SMSMCP') - CALL DALLOC (INDEX,'INDEX','SMSMCP') - CALL DALLOC (NSWAP,'NSWAP','SMSMCP') - NDIM = NCONTR - CALL ALLOC (COEFF, NDIM,'COEFF','SMSMCP') - CALL ALLOC (ICLMN, NDIM,'ICLMN','SMSMCP') - CALL ALLOC (INDEX, NDIM,'INDEX','SMSMCP') - CALL ALLOC (NSWAP, NDIM,'NSWAP','SMSMCP') - ENDIF + IF (NCONTR > NDIM) THEN + CALL DALLOC (COEFF,'COEFF','SMSMCP') + CALL DALLOC (ICLMN,'ICLMN','SMSMCP') + CALL DALLOC (INDEX,'INDEX','SMSMCP') + CALL DALLOC (NSWAP,'NSWAP','SMSMCP') + NDIM = NCONTR + CALL ALLOC (COEFF, NDIM,'COEFF','SMSMCP') + CALL ALLOC (ICLMN, NDIM,'ICLMN','SMSMCP') + CALL ALLOC (INDEX, NDIM,'INDEX','SMSMCP') + CALL ALLOC (NSWAP, NDIM,'NSWAP','SMSMCP') + ENDIF ! ! Read the column index, the sparse matrix index, and the ! coefficient for all contributions from this integral ! - READ (NFILE) (ICLMN(I),INDEX(I),COEFF(I),I=1,NCONTR) - READ (20) (NSWAP(I),I=1,NCONTR) + READ (NFILE) (ICLMN(I),INDEX(I),COEFF(I),I=1,NCONTR) + READ (20) (NSWAP(I),I=1,NCONTR) ! ! Store all the contributions from this integral ! - DO I = 1, NCONTR - LOC = INDEX(I) - EMT(LOC) = EMT(LOC) - TEGRAL*COEFF(I)*(-1)**NSWAP(I) - END DO + DO I = 1, NCONTR + LOC = INDEX(I) + EMT(LOC) = EMT(LOC) - TEGRAL*COEFF(I)*(-1)**NSWAP(I) + END DO ! ! Return to the start of the loop ! - GO TO 18 + GO TO 18 ! - ENDIF + ENDIF ! ! ! Deallocate storage that is local to this routine ! - CALL DALLOC (COEFF,'COEFF','SMSMCP') - CALL DALLOC (ICLMN,'ICLMN','SMSMCP') - CALL DALLOC (INDEX,'INDEX','SMSMCP') - CALL DALLOC (NSWAP,'NSWAP','SMSMCP') - - ICI = 0 - DO I = 1, NELMNT - IRI = IROW(I) - IF (I > IENDC(ICI)) ICI = ICI + 1 - DO J = 1, NVEC - LOC = (J - 1)*NCF - CONTRI = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT(I) - IF (IRI /= ICI) CONTRI = 2.0D00*CONTRI - SMSC(J) = SMSC(J) + CONTRI - END DO - END DO - CALL DALLOC (EMT, 'EMT', 'SMSMCP') - CALL DALLOC (IENDC,'IENDC','SMSMCP') - CALL DALLOC (IROW, 'IROW', 'SMSMCP') + CALL DALLOC (COEFF,'COEFF','SMSMCP') + CALL DALLOC (ICLMN,'ICLMN','SMSMCP') + CALL DALLOC (INDEX,'INDEX','SMSMCP') + CALL DALLOC (NSWAP,'NSWAP','SMSMCP') + + ICI = 0 + DO I = 1, NELMNT + IRI = IROW(I) + IF (I > IENDC(ICI)) ICI = ICI + 1 + DO J = 1, NVEC + LOC = (J - 1)*NCF + CONTRI = EVEC(ICI + LOC)*EVEC(IRI + LOC)*EMT(I) + IF (IRI /= ICI) CONTRI = 2.0D00*CONTRI + SMSC(J) = SMSC(J) + CONTRI + END DO + END DO + CALL DALLOC (EMT, 'EMT', 'SMSMCP') + CALL DALLOC (IENDC,'IENDC','SMSMCP') + CALL DALLOC (IROW, 'IROW', 'SMSMCP') ! ! Close the angular files ! - CLOSE(20) - DO I = 30, 32 + KMAXF - CLOSE(I) - END DO - RETURN - END SUBROUTINE SMSMCP + CLOSE(20) + DO I = 30, 32 + KMAXF + CLOSE(I) + END DO + RETURN + END SUBROUTINE SMSMCP diff --git a/src/appl/sms90/smsmcp_I.f90 b/src/appl/sms90/smsmcp_I.f90 index 63aa12d05..5d6a7c082 100644 --- a/src/appl/sms90/smsmcp_I.f90 +++ b/src/appl/sms90/smsmcp_I.f90 @@ -1,12 +1,12 @@ - MODULE smsmcp_I + MODULE smsmcp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:46:30 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:46:30 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE smsmcp (VINT) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE smsmcp (VINT) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: VINT - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: VINT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/smsnew.f90 b/src/appl/sms90/smsnew.f90 index 6b2a6f64d..401c9dda7 100644 --- a/src/appl/sms90/smsnew.f90 +++ b/src/appl/sms90/smsnew.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SMSNEW(VINT) + SUBROUTINE SMSNEW(VINT) ! * ! This routine controls the main sequence of routine calls for the * ! calculation of the sms parameter, the electron density at the * @@ -17,17 +17,17 @@ SUBROUTINE SMSNEW(VINT) ! Last revision: Nov 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:48:15 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:48:15 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE BUFFER_C - USE TEILST_C - USE SMS1_C + USE BUFFER_C + USE TEILST_C + USE SMS1_C USE debug_C USE decide_C USE def_C @@ -41,51 +41,51 @@ SUBROUTINE SMSNEW(VINT) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cord_I - USE alcbuf_I - USE convrt_I - USE itjpo_I - USE rkco_gg_I + USE cord_I + USE alcbuf_I + USE convrt_I + USE itjpo_I + USE rkco_gg_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(IN) :: VINT(NNNW,NNNW) + REAL(DOUBLE) , INTENT(IN) :: VINT(NNNW,NNNW) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- -! REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 +! REAL(DOUBLE), PARAMETER :: CUTOFF = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: INCOR, IC, LCNUM, ITJPOC, IR, I, IIA, IIB, IIC, IID, K, J, LOC - REAL(DOUBLE) :: VCOEFF, CONTRI - LOGICAL :: GETYN, VSH, NUCDE, SMSSH, YES - CHARACTER :: CNUM*11, CK*2 + INTEGER :: INCOR, IC, LCNUM, ITJPOC, IR, I, IIA, IIB, IIC, IID, K, J, LOC + REAL(DOUBLE) :: VCOEFF, CONTRI + LOGICAL :: GETYN, VSH, NUCDE, SMSSH, YES + CHARACTER :: CNUM*11, CK*2 !----------------------------------------------- ! ! Matrix elements smaller than CUTOFF are not accumulated ! ! - INCOR = 1 + INCOR = 1 ! ! Allocate storage for the arrays in BUFFER ! - CALL ALCBUF (1) + CALL ALCBUF (1) ! ! Sweep through the Hamiltonian matrix to determine the ! sms parameter ! - DO IC = 1, NCF + DO IC = 1, NCF ! ! Output IC on the screen to show how far the calculation has preceede ! - CALL CONVRT (IC, CNUM, LCNUM) + CALL CONVRT (IC, CNUM, LCNUM) IF (MOD(IC,10) == 0) WRITE (6, *) 'Column '//CNUM(1:LCNUM)//& - ' complete;' + ' complete;' ! - ITJPOC = ITJPO(IC) - DO IR = IC, NCF + ITJPOC = ITJPO(IC) + DO IR = IC, NCF ! ! Call the MCP package to generate V coefficients; ac and bd ! are the density pairs @@ -95,42 +95,42 @@ SUBROUTINE SMSNEW(VINT) ! ! Matrix elements are diagonal in J ! - IF (ITJPO(IR) /= ITJPOC) CYCLE - NVCOEF = 0 -!GG CALL RKCO (IC, IR, COR, CORD, INCOR) + IF (ITJPO(IR) /= ITJPOC) CYCLE + NVCOEF = 0 +!GG CALL RKCO (IC, IR, COR, CORD, INCOR) CALL RKCO_GG (IC, IR, CORD, INCOR, 1) ! - DO I = 1, NVCOEF - VCOEFF = COEFF(I) - IF (ABS(VCOEFF) <= CUTOFF) CYCLE - IIA = LABEL(1,I) - IIB = LABEL(2,I) - IIC = LABEL(3,I) - IID = LABEL(4,I) - K = LABEL(5,I) + DO I = 1, NVCOEF + VCOEFF = COEFF(I) + IF (ABS(VCOEFF) <= CUTOFF) CYCLE + IIA = LABEL(1,I) + IIB = LABEL(2,I) + IIC = LABEL(3,I) + IID = LABEL(4,I) + K = LABEL(5,I) ! ! Only K = 1 LABEL(5,I) .EQ. 1 ! - IF (LABEL(5,I) /= 1) CYCLE + IF (LABEL(5,I) /= 1) CYCLE IF (LDBPA(2)) WRITE (99, 309) K, IC, IR, NP(IIA), NH(IIA), NP(& - IIB), NH(IIB), NP(IIC), NH(IIC), NP(IID), NH(IID), VCOEFF - DO J = 1, NVEC - LOC = (J - 1)*NCF + IIB), NH(IIB), NP(IIC), NH(IIC), NP(IID), NH(IID), VCOEFF + DO J = 1, NVEC + LOC = (J - 1)*NCF CONTRI = -EVEC(IC + LOC)*EVEC(IR + LOC)*VCOEFF*VINT(LABEL(1,I& - ),LABEL(3,I))*VINT(LABEL(2,I),LABEL(4,I)) - IF (IR /= IC) CONTRI = 2.0D00*CONTRI - SMSC(J) = SMSC(J) + CONTRI - END DO - END DO - END DO - END DO + ),LABEL(3,I))*VINT(LABEL(2,I),LABEL(4,I)) + IF (IR /= IC) CONTRI = 2.0D00*CONTRI + SMSC(J) = SMSC(J) + CONTRI + END DO + END DO + END DO + END DO ! ! Deallocate storage for the arrays in BUFFER ! - CALL ALCBUF (3) - RETURN + CALL ALCBUF (3) + RETURN 309 FORMAT(' V^[(',1I2,')]_[',1I3,',',1I3,']',' (',1I2,1A2,',',1I2,1A2,';',1I& - 2,1A2,',',1I2,1A2,') = ',1P,D19.12) - RETURN + 2,1A2,',',1I2,1A2,') = ',1P,D19.12) + RETURN ! - END SUBROUTINE SMSNEW + END SUBROUTINE SMSNEW diff --git a/src/appl/sms90/smsnew_I.f90 b/src/appl/sms90/smsnew_I.f90 index 4d6e3506f..c0461a55b 100644 --- a/src/appl/sms90/smsnew_I.f90 +++ b/src/appl/sms90/smsnew_I.f90 @@ -1,12 +1,12 @@ - MODULE smsnew_I + MODULE smsnew_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 18:48:15 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 18:48:15 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE smsnew (VINT) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE smsnew (VINT) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: VINT - END SUBROUTINE - END INTERFACE - END MODULE + REAL(DOUBLE), DIMENSION(NNNW,NNNW), INTENT(IN) :: VINT + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/strsum.f90 b/src/appl/sms90/strsum.f90 index 3f59fc8a8..394cce439 100644 --- a/src/appl/sms90/strsum.f90 +++ b/src/appl/sms90/strsum.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE STRSUM + SUBROUTINE STRSUM ! * ! Generates the first part of sms92.sum (on stream 24). * ! * @@ -9,11 +9,11 @@ SUBROUTINE STRSUM ! Written by Farid A. Parpia Last revision: 28 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW @@ -32,15 +32,15 @@ SUBROUTINE STRSUM !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I - USE engout_I - USE wghtd5_I + USE convrt_I + USE engout_I + USE wghtd5_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENTH, I - CHARACTER :: RECORD*256, CDATA*26 + INTEGER :: LENTH, I + CHARACTER :: RECORD*256, CDATA*26 !----------------------------------------------- ! ! Get the date and time of day; make this information the @@ -49,88 +49,88 @@ SUBROUTINE STRSUM ! ! Write out the basic dimensions of the electron cloud ! - WRITE (24, *) - CALL CONVRT (NELEC, RECORD, LENTH) - WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' - CALL CONVRT (NW, RECORD, LENTH) - WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' + WRITE (24, *) + CALL CONVRT (NELEC, RECORD, LENTH) + WRITE (24, *) 'There are '//RECORD(1:LENTH)//' electrons in the cloud' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (24, *) ' in '//RECORD(1:LENTH)//' relativistic CSFs' + CALL CONVRT (NW, RECORD, LENTH) + WRITE (24, *) ' based on '//RECORD(1:LENTH)//' relativistic subshells.' ! ! If the CSFs are not treated uniformly, write out an ! informative message ! - IF (LFORDR) THEN - WRITE (24, *) - CALL CONVRT (ICCUT(1), RECORD, LENTH) + IF (LFORDR) THEN + WRITE (24, *) + CALL CONVRT (ICCUT(1), RECORD, LENTH) WRITE (24, *) ' CSFs 1--'//RECORD(1:LENTH)//' constitute'//& - ' the zero-order space;' - ENDIF + ' the zero-order space;' + ENDIF ! ! Write out the nuclear parameters ! - WRITE (24, *) - WRITE (24, 300) Z - IF (NPARM == 2) THEN - WRITE (24, *) 'Fermi nucleus:' - WRITE (24, 301) PARM(1), PARM(2) - CALL CONVRT (NNUC, RECORD, LENTH) + WRITE (24, *) + WRITE (24, 300) Z + IF (NPARM == 2) THEN + WRITE (24, *) 'Fermi nucleus:' + WRITE (24, 301) PARM(1), PARM(2) + CALL CONVRT (NNUC, RECORD, LENTH) WRITE (24, *) ' there are '//RECORD(1:LENTH)//& - ' tabulation points in the nucleus.' - ELSE - WRITE (24, *) ' point nucleus.' - ENDIF + ' tabulation points in the nucleus.' + ELSE + WRITE (24, *) ' point nucleus.' + ENDIF ! ! Write out the physical effects specifications ! - WRITE (24, *) - WRITE (24, 305) C + WRITE (24, *) + WRITE (24, 305) C ! ! Write out the parameters of the radial grid ! - WRITE (24, *) - IF (HP == 0.0D00) THEN - WRITE (24, 306) RNT, H, N - ELSE - WRITE (24, 307) RNT, H, HP, N - ENDIF - WRITE (24, 308) R(1), R(2), R(N) + WRITE (24, *) + IF (HP == 0.0D00) THEN + WRITE (24, 306) RNT, H, N + ELSE + WRITE (24, 307) RNT, H, HP, N + ENDIF + WRITE (24, 308) R(1), R(2), R(N) ! ! Write out the orbital properties ! - WRITE (24, *) - WRITE (24, *) 'Subshell radial wavefunction summary:' - WRITE (24, *) - WRITE (24, 309) - WRITE (24, *) - DO I = 1, NW + WRITE (24, *) + WRITE (24, *) 'Subshell radial wavefunction summary:' + WRITE (24, *) + WRITE (24, 309) + WRITE (24, *) + DO I = 1, NW WRITE (24, 310) NP(I), NH(I), E(I), PZ(I), GAMA(I), PF(2,I), QF(2,I), & - MF(I) - END DO + MF(I) + END DO ! ! Write the list of eigenpair indices ! - WRITE (24, *) - CALL ENGOUT (EAV, EVAL, IATJPO, IASPAR, IVEC, NVEC, 3) - CALL WGHTD5 + WRITE (24, *) + CALL ENGOUT (EAV, EVAL, IATJPO, IASPAR, IVEC, NVEC, 3) + CALL WGHTD5 ! - RETURN + RETURN ! - 300 FORMAT('The atomic number is ',1F14.10,';') - 301 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') - 305 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') + 300 FORMAT('The atomic number is ',1F14.10,';') + 301 FORMAT(' c =',1P,1D19.12,' Bohr radii,'/,' a =',1D19.12,' Bohr radii;') + 305 FORMAT('Speed of light = ',1P,D19.12,' atomic units.') 306 FORMAT('Radial grid: R(I) = RNT*(exp((I-1)*H)-1),',' I = 1, ..., N;'/,/,& ' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D19.12,' Bohr radii;'/& - ,' N = ',1I4,';') + ,' N = ',1I4,';') 307 FORMAT('Radial grid: ln(R(I)/RNT+1)+(H/HP)*R(I) = (I-1)*H,',& ' I = 1, ..., N;'/,/,' RNT = ',1P,D19.12,' Bohr radii;'/,' H = ',D& 19.12,' Bohr radii;'/,' HP = ',D19.12,' Bohr radii;'/,' N = ',1I4& - ,';') + ,';') 308 FORMAT(' R(1) = ',1P,1D19.12,' Bohr radii;'/,' R(2) = ',1D19.12,& - ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') + ' Bohr radii;'/,' R(N) = ',1D19.12,' Bohr radii.') 309 FORMAT(' Subshell',11X,'e',20X,'p0',18X,'gamma',19X,'P(2)',18X,'Q(2)',10X& - ,'MTP') - 310 FORMAT(3X,1I2,1A2,1X,1P,5(3X,1D19.12),3X,1I3) - RETURN + ,'MTP') + 310 FORMAT(3X,1I2,1A2,1X,1P,5(3X,1D19.12),3X,1I3) + RETURN ! - END SUBROUTINE STRSUM + END SUBROUTINE STRSUM diff --git a/src/appl/sms90/strsum_I.f90 b/src/appl/sms90/strsum_I.f90 index 14d09a5bc..376dbc0f1 100644 --- a/src/appl/sms90/strsum_I.f90 +++ b/src/appl/sms90/strsum_I.f90 @@ -1,9 +1,9 @@ - MODULE strsum_I + MODULE strsum_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE strsum - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE strsum + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/appl/sms90/teilst_C.f90 b/src/appl/sms90/teilst_C.f90 index 35e43fa58..8b7cd28a9 100644 --- a/src/appl/sms90/teilst_C.f90 +++ b/src/appl/sms90/teilst_C.f90 @@ -1,5 +1,5 @@ MODULE teilst_C -!...Created by Charlotte Froese Fischer +!...Created by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 INTEGER :: NDTEA,NTEI,PINDTE,PVALTE LOGICAL :: FIRSTT diff --git a/src/appl/sms90/vinti.f90 b/src/appl/sms90/vinti.f90 index e57c9d512..2a270a110 100644 --- a/src/appl/sms90/vinti.f90 +++ b/src/appl/sms90/vinti.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) + REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! * ! The value of this function is the one-electron integral V (J,K) * ! for orbitals J, K. The analytical expression for this quantity * @@ -12,13 +12,13 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) ! Written by M Tong and F A Parpia, Last revision: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:07:11 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE debug_C USE grid_C USE orb_C @@ -27,56 +27,56 @@ REAL(KIND(0.0D0)) FUNCTION VINTI (J, K) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dpbdt_I - USE quad_I + USE dpbdt_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: K + INTEGER :: J + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 - REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 + INTEGER :: I, KPJ, KPK, IFACT1, IFACT2 + REAL(DOUBLE) :: PIECE1, FACT1, FACT2, PIECE2 !----------------------------------------------- ! - MTP = MAX(MF(J),MF(K)) + MTP = MAX(MF(J),MF(K)) ! ! Piece involving derivatives ! - CALL DPBDT (K) - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = PIECE1/H + CALL DPBDT (K) + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = PF(I,J)*TA(I) + QF(I,J)*TB(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = PIECE1/H ! ! Pieces not involving derivatives ! - KPJ = NAK(J) - KPK = NAK(K) - IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) - FACT1 = 0.5D00*DBLE(IFACT1) - IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) - FACT2 = 0.5D00*DBLE(IFACT2) - TA(1) = 0.0D00 - DO I = 2, MTP + KPJ = NAK(J) + KPK = NAK(K) + IFACT1 = KPJ*(KPJ + 1) - KPK*(KPK + 1) + FACT1 = 0.5D00*DBLE(IFACT1) + IFACT2 = (-KPJ*((-KPJ) + 1)) + KPK*((-KPK) + 1) + FACT2 = 0.5D00*DBLE(IFACT2) + TA(1) = 0.0D00 + DO I = 2, MTP TA(I) = RPOR(I)*(FACT1*PF(I,J)*PF(I,K) + FACT2*QF(I,J)*QF(I,K)) - END DO - CALL QUAD (PIECE2) + END DO + CALL QUAD (PIECE2) ! - VINTI = PIECE1 - PIECE2 + VINTI = PIECE1 - PIECE2 ! ! Debug printout ! - IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI + IF (LDBPR(6)) WRITE (99, 300) NP(J), NH(J), NP(K), NH(K), VINTI ! - RETURN + RETURN ! - 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) - RETURN + 300 FORMAT(/,'VINTI: V (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12) + RETURN ! - END FUNCTION VINTI + END FUNCTION VINTI diff --git a/src/appl/sms90/vinti_I.f90 b/src/appl/sms90/vinti_I.f90 index 611f8cad9..fc246e98f 100644 --- a/src/appl/sms90/vinti_I.f90 +++ b/src/appl/sms90/vinti_I.f90 @@ -1,11 +1,11 @@ - MODULE vinti_I + MODULE vinti_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:40:03 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - REAL(KIND(0.0D0)) FUNCTION vinti (J, K) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION vinti (J, K) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/appl/sms90/wghtd5.f90 b/src/appl/sms90/wghtd5.f90 index 3ed1ce86f..74cc4a44f 100644 --- a/src/appl/sms90/wghtd5.f90 +++ b/src/appl/sms90/wghtd5.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE WGHTD5 + SUBROUTINE WGHTD5 ! * ! Print the weights of the largest five CSF contributors to each * ! ASF. * @@ -10,19 +10,19 @@ SUBROUTINE WGHTD5 ! Last updated: 02 Nov 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 08:39:50 2/21/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 08:39:50 2/21/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE EIGV_C - USE JLABL_C - USE ORB_C - USE PRNT_C - USE SYMA_C + USE EIGV_C + USE JLABL_C + USE ORB_C + USE PRNT_C + USE SYMA_C USE itjpo_I use ispar_I !----------------------------------------------- @@ -32,95 +32,95 @@ SUBROUTINE WGHTD5 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(5) :: ICONF + INTEGER, DIMENSION(5) :: ICONF REAL(DOUBLE),dimension(5)::wght - INTEGER :: NELT, NVEX, IV, ICF, IFIRST, I, M, L, IP + INTEGER :: NELT, NVEX, IV, ICF, IFIRST, I, M, L, IP integer, dimension(:), pointer :: NEXT; REAL(DOUBLE),dimension(:), pointer :: WT !----------------------------------------------- ! ! Allocate storage for local arrays ! - CALL ALLOC (WT, NCF, 'WT', 'WGHTD5' ) - CALL ALLOC (NEXT, NCF, 'NEXT', 'WGHTD5') + CALL ALLOC (WT, NCF, 'WT', 'WGHTD5' ) + CALL ALLOC (NEXT, NCF, 'NEXT', 'WGHTD5') ! - WRITE (24, 300) + WRITE (24, 300) ! - IF (NCF < 5) NELT = NCF + IF (NCF < 5) NELT = NCF ! - NVEX = NVEC + NVEX = NVEC ! - DO IV = 1, NVEX + DO IV = 1, NVEX ! - ICF = IVEC(IV) + ICF = IVEC(IV) ! ! Set up linked list of weights ! - NEXT(1) = 0 - WT(1) = EVEC(1 + (IV - 1)*NCF)**2 - IFIRST = 1 - L4: DO I = 2, NCF - M = IFIRST - L = 0 - WT(I) = EVEC(I + (IV - 1)*NCF)**2 - IF (WT(I) > WT(M)) THEN - IF (L /= 0) GO TO 3 - NEXT(I) = IFIRST - IFIRST = I - CYCLE L4 - ENDIF - L = M - M = NEXT(L) - DO WHILE(M /= 0) - IF (WT(I) > WT(M)) THEN - IF (L /= 0) GO TO 3 - NEXT(I) = IFIRST - IFIRST = I - CYCLE L4 - ENDIF - L = M - M = NEXT(L) - END DO - 3 CONTINUE - NEXT(I) = NEXT(L) - NEXT(L) = I - END DO L4 + NEXT(1) = 0 + WT(1) = EVEC(1 + (IV - 1)*NCF)**2 + IFIRST = 1 + L4: DO I = 2, NCF + M = IFIRST + L = 0 + WT(I) = EVEC(I + (IV - 1)*NCF)**2 + IF (WT(I) > WT(M)) THEN + IF (L /= 0) GO TO 3 + NEXT(I) = IFIRST + IFIRST = I + CYCLE L4 + ENDIF + L = M + M = NEXT(L) + DO WHILE(M /= 0) + IF (WT(I) > WT(M)) THEN + IF (L /= 0) GO TO 3 + NEXT(I) = IFIRST + IFIRST = I + CYCLE L4 + ENDIF + L = M + M = NEXT(L) + END DO + 3 CONTINUE + NEXT(I) = NEXT(L) + NEXT(L) = I + END DO L4 ! ! Print first five elements of list. ! - M = IFIRST - I = 0 - IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN - I = I + 1 - WGHT(I) = WT(M) - ICONF(I) = M - ENDIF - M = NEXT(M) - DO WHILE(M/=0 .AND. I<5) - IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN - I = I + 1 - WGHT(I) = WT(M) - ICONF(I) = M - ENDIF - M = NEXT(M) - END DO - IP = (IASPAR(IV) + 3)/2 - NELT = MIN(I,5) - WRITE (24, 301) ICF, JLBL(IATJPO(IV)), JLBP(IP), (WGHT(I),I=1,NELT) - WRITE (24, 302) (ICONF(I),I=1,NELT) - END DO + M = IFIRST + I = 0 + IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN + I = I + 1 + WGHT(I) = WT(M) + ICONF(I) = M + ENDIF + M = NEXT(M) + DO WHILE(M/=0 .AND. I<5) + IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN + I = I + 1 + WGHT(I) = WT(M) + ICONF(I) = M + ENDIF + M = NEXT(M) + END DO + IP = (IASPAR(IV) + 3)/2 + NELT = MIN(I,5) + WRITE (24, 301) ICF, JLBL(IATJPO(IV)), JLBP(IP), (WGHT(I),I=1,NELT) + WRITE (24, 302) (ICONF(I),I=1,NELT) + END DO ! ! Deallocate storage for local arrays ! - CALL DALLOC (WT, 'WT', 'WGHTD5') - CALL DALLOC (NEXT, 'NEXT', 'WGHTD5') + CALL DALLOC (WT, 'WT', 'WGHTD5') + CALL DALLOC (NEXT, 'NEXT', 'WGHTD5') ! - RETURN + RETURN ! 300 FORMAT(/,'Weights of major contributors to ASF:'/,/,& - 'Level J Parity CSF contributions'/) - 301 FORMAT(I3,2X,2A4,5(D12.4)) - 302 FORMAT(13X,5I12) - RETURN + 'Level J Parity CSF contributions'/) + 301 FORMAT(I3,2X,2A4,5(D12.4)) + 302 FORMAT(13X,5I12) + RETURN ! - END SUBROUTINE WGHTD5 + END SUBROUTINE WGHTD5 diff --git a/src/appl/sms90/wghtd5_I.f90 b/src/appl/sms90/wghtd5_I.f90 index 552521bb5..e66433eee 100644 --- a/src/appl/sms90/wghtd5_I.f90 +++ b/src/appl/sms90/wghtd5_I.f90 @@ -1,9 +1,9 @@ - MODULE wghtd5_I + MODULE wghtd5_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 08:39:50 2/21/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 08:39:50 2/21/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 11/02/17 - SUBROUTINE wghtd5 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE wghtd5 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/Makefile b/src/lib/Makefile old mode 100755 new mode 100644 index deae05c7e..e6bb6c879 --- a/src/lib/Makefile +++ b/src/lib/Makefile @@ -20,5 +20,3 @@ clean: $(MAKE) $@ ; \ cd .. ; \ done - - diff --git a/src/lib/lib9290/Makefile b/src/lib/lib9290/Makefile old mode 100755 new mode 100644 index 4b402d305..d67f52833 --- a/src/lib/lib9290/Makefile +++ b/src/lib/lib9290/Makefile @@ -42,7 +42,7 @@ OBJ = \ setcon.o install : $(LIBA) -$(LIBA) : $(LIBOBJ) +$(LIBA) : $(LIBOBJ) @echo " Building " $(LIBA) ar -crvs $(LIBA) $? diff --git a/src/lib/lib9290/alcbuf.f90 b/src/lib/lib9290/alcbuf.f90 index 474e76dfa..1d721fda5 100644 --- a/src/lib/lib9290/alcbuf.f90 +++ b/src/lib/lib9290/alcbuf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ALCBUF(MODE) + SUBROUTINE ALCBUF(MODE) ! * ! The arrays in MODULE BUFFER_C are allocated (MODE = 1), realloca- * ! ted (MODE = 2), and deallocated (MODE = 3) in this routine. * @@ -11,8 +11,8 @@ SUBROUTINE ALCBUF(MODE) ! Editted after translation by C. Froese Fischer 29 Apr 2007 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 16:02:30 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 16:02:30 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !==================================================================== @@ -25,47 +25,47 @@ SUBROUTINE ALCBUF(MODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: MODE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSIZ, IERR + INTEGER :: NEWSIZ, IERR ! ! - SELECT CASE (MODE) - CASE (1) + SELECT CASE (MODE) + CASE (1) ! ! Allocation ! - NBDIM = 10 + NBDIM = 10 CALL ALLOC (LABEL, 6,NBDIM, 'LABEL', 'ALCBUF') - CALL ALLOC (COEFF, NBDIM, 'COEFF', 'ALCBUF') + CALL ALLOC (COEFF, NBDIM, 'COEFF', 'ALCBUF') ! - CASE (2) + CASE (2) ! ! Reallocation to double storage ! - NEWSIZ = NBDIM + NBDIM + NEWSIZ = NBDIM + NBDIM CALL RALLOC(LABEL,6,NEWSIZ, 'LABEL', 'ALCBUF') CALL RALLOC(COEFF,NEWSIZ, 'COEFF', 'ALCBUF') - NBDIM = NEWSIZ + NBDIM = NEWSIZ ! - CASE (3) + CASE (3) ! ! Deallocation ! CALL DALLOC(label, 'LABEL', 'ALCBUF') CALL DALLOC(coeff, 'COEFF', 'ALCBUF') ! - CASE DEFAULT + CASE DEFAULT ! ! Argument error ! - WRITE (6, *) 'ALCBUF: Invalid argument MODE = ', MODE - STOP + WRITE (6, *) 'ALCBUF: Invalid argument MODE = ', MODE + STOP ! - END SELECT + END SELECT ! - RETURN + RETURN ! - END SUBROUTINE ALCBUF + END SUBROUTINE ALCBUF diff --git a/src/lib/lib9290/alcbuf_I.f90 b/src/lib/lib9290/alcbuf_I.f90 index c75dc4412..4712a77e3 100644 --- a/src/lib/lib9290/alcbuf_I.f90 +++ b/src/lib/lib9290/alcbuf_I.f90 @@ -1,12 +1,12 @@ - MODULE alcbuf_I + MODULE alcbuf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 16:02:30 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 16:02:30 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE alcbuf (MODE) - INTEGER, INTENT(IN) :: MODE + SUBROUTINE alcbuf (MODE) + INTEGER, INTENT(IN) :: MODE !VAST...Calls: ALLOC, RALLOC, DALLOC !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/arctan.f90 b/src/lib/lib9290/arctan.f90 index 9a1a5e524..7990938c6 100644 --- a/src/lib/lib9290/arctan.f90 +++ b/src/lib/lib9290/arctan.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION ARCTAN (ARG1, ARG2) + REAL(KIND(0.0D0)) FUNCTION ARCTAN (ARG1, ARG2) !----------------------------------------------- ! * ! -1 * @@ -10,21 +10,21 @@ REAL(KIND(0.0D0)) FUNCTION ARCTAN (ARG1, ARG2) ! Editted by C. Froese Fischer after translation * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:34 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:34 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C ! IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(IN) :: ARG1 - REAL(DOUBLE), INTENT(IN) :: ARG2 + REAL(DOUBLE), INTENT(IN) :: ARG1 + REAL(DOUBLE), INTENT(IN) :: ARG2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -35,28 +35,28 @@ REAL(KIND(0.0D0)) FUNCTION ARCTAN (ARG1, ARG2) ! Determine whether the FORTRAN intrinsic function ATAN2 always ! returns a positive value ! - IF (FIRST) THEN - ARCTAN = ATAN2(-1.0D00,-1.0D00) - IF (ARCTAN > 0.0D00) THEN - INTRIN = .TRUE. - ELSE - INTRIN = .FALSE. - ENDIF - FIRST = .FALSE. - ENDIF + IF (FIRST) THEN + ARCTAN = ATAN2(-1.0D00,-1.0D00) + IF (ARCTAN > 0.0D00) THEN + INTRIN = .TRUE. + ELSE + INTRIN = .FALSE. + ENDIF + FIRST = .FALSE. + ENDIF ! ! Use the intrinsic function if it passes the above test; otherwise ! add 2*PI to the negative values returned by the intrinsic function ! - IF (INTRIN) THEN - ARCTAN = ATAN2(ARG1,ARG2) - ELSE - IF (ARG1 >= 0.0D00) THEN - ARCTAN = ATAN2(ARG1,ARG2) - ELSE - ARCTAN = PI + PI + ATAN2(ARG1,ARG2) - ENDIF - ENDIF + IF (INTRIN) THEN + ARCTAN = ATAN2(ARG1,ARG2) + ELSE + IF (ARG1 >= 0.0D00) THEN + ARCTAN = ATAN2(ARG1,ARG2) + ELSE + ARCTAN = PI + PI + ATAN2(ARG1,ARG2) + ENDIF + ENDIF ! - RETURN - END FUNCTION ARCTAN + RETURN + END FUNCTION ARCTAN diff --git a/src/lib/lib9290/arctan_I.f90 b/src/lib/lib9290/arctan_I.f90 index 2bb2d9313..e895a6211 100644 --- a/src/lib/lib9290/arctan_I.f90 +++ b/src/lib/lib9290/arctan_I.f90 @@ -1,13 +1,13 @@ - MODULE arctan_I + MODULE arctan_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:34 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:34 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION arctan (ARG1, ARG2) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: ARG1 - REAL(DOUBLE), INTENT(IN) :: ARG2 + REAL(KIND(0.0D0)) FUNCTION arctan (ARG1, ARG2) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: ARG1 + REAL(DOUBLE), INTENT(IN) :: ARG2 !VAST.../DEF9/ PI(IN) - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/calen.f90 b/src/lib/lib9290/calen.f90 index 506a71ce3..9bfbc3d6a 100644 --- a/src/lib/lib9290/calen.f90 +++ b/src/lib/lib9290/calen.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CALEN(JTIME, JDATE) + SUBROUTINE CALEN(JTIME, JDATE) ! * ! Loads the character strings JTIME and JDATE with the time of day * ! and the date when called. * @@ -8,18 +8,18 @@ SUBROUTINE CALEN(JTIME, JDATE) ! Last revision: 25 Sep 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER :: JTIME*10 - CHARACTER :: JDATE*8 + CHARACTER :: JTIME*10 + CHARACTER :: JDATE*8 CALL DATE_AND_TIME(JDATE, JTIME) - - RETURN - END SUBROUTINE CALEN + + RETURN + END SUBROUTINE CALEN diff --git a/src/lib/lib9290/calen_I.f90 b/src/lib/lib9290/calen_I.f90 index 8e3e31f6d..d5643b854 100644 --- a/src/lib/lib9290/calen_I.f90 +++ b/src/lib/lib9290/calen_I.f90 @@ -1,11 +1,11 @@ - MODULE calen_I + MODULE calen_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE calen (JTIME, JDATE) - CHARACTER(LEN=10) :: JTIME - CHARACTER(LEN=8) :: JDATE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE calen (JTIME, JDATE) + CHARACTER(LEN=10) :: JTIME + CHARACTER(LEN=8) :: JDATE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/cgamma.f90 b/src/lib/lib9290/cgamma.f90 index 35e84bef4..99ddc6a46 100644 --- a/src/lib/lib9290/cgamma.f90 +++ b/src/lib/lib9290/cgamma.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CGAMMA(ARGR, ARGI, RESR, RESI) + SUBROUTINE CGAMMA(ARGR, ARGI, RESR, RESI) ! * ! This subroutine returns in RES the complex Gamma function of the * ! complex argument ARG. The suffixes R and I respectively distin- * @@ -16,203 +16,203 @@ SUBROUTINE CGAMMA(ARGR, ARGI, RESR, RESI) ! Written by Farid A Parpia, at Oxford Last update: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:48 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:48 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE arctan_I + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE arctan_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(IN) :: ARGI, ARGR - REAL(DOUBLE), INTENT(OUT) :: RESR, RESI + REAL(DOUBLE), INTENT(IN) :: ARGI, ARGR + REAL(DOUBLE), INTENT(OUT) :: RESR, RESI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE), DIMENSION(7) :: FN, FD + INTEGER :: I + REAL(DOUBLE), DIMENSION(7) :: FN, FD REAL(DOUBLE) :: HLNTPI, TWOI, DIFF, ARGUM, CLNGI, FACNEG, ARGUR, OVLFAC, & CLNGR, FAC, OBASQ, ARGUI, ARGUI2, OVLFR, OVLFI, TERMR, TERMI, ARGUR2, & - OBASQR, OBASQI, ZFACR, ZFACI - LOGICAL,SAVE :: FIRST, NEGARG + OBASQR, OBASQI, ZFACR, ZFACI + LOGICAL,SAVE :: FIRST, NEGARG !----------------------------------------------------------------------* ! * ! These are the Bernoulli numbers B02, B04, ..., B14, expressed as * ! rational numbers. From abramowitz and stegun, p. 810. * ! - DATA FN/ 1.0D00, -1.0D00, 1.0D00, -1.0D00, 5.0D00, -691.0D00, 7.0D00/ - DATA FD/ 6.0D00, 30.0D00, 42.0D00, 30.0D00, 66.0D00, 2730.0D00, 6.0D00/ + DATA FN/ 1.0D00, -1.0D00, 1.0D00, -1.0D00, 5.0D00, -691.0D00, 7.0D00/ + DATA FD/ 6.0D00, 30.0D00, 42.0D00, 30.0D00, 66.0D00, 2730.0D00, 6.0D00/ ! !----------------------------------------------------------------------* ! - DATA HLNTPI/ 1.0D00/ + DATA HLNTPI/ 1.0D00/ ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! On the first entry to this routine, set up the constants required ! for the reflection formula (cf. Abramowitz and Stegun 6.1.17) and ! Stirling's approximation (cf. Abramowitz and Stegun 6.1.40). ! - IF (FIRST) THEN + IF (FIRST) THEN ! - HLNTPI = 0.5D00*LOG(PI + PI) + HLNTPI = 0.5D00*LOG(PI + PI) ! - DO I = 1, 7 - FN(I) = FN(I)/FD(I) - TWOI = DBLE(I + I) - FN(I) = FN(I)/(TWOI*(TWOI - 1.0D00)) - END DO + DO I = 1, 7 + FN(I) = FN(I)/FD(I) + TWOI = DBLE(I + I) + FN(I) = FN(I)/(TWOI*(TWOI - 1.0D00)) + END DO ! - FIRST = .FALSE. + FIRST = .FALSE. ! - ENDIF + ENDIF ! ! Cases where the argument is real ! - IF (ARGI == 0.0D00) THEN + IF (ARGI == 0.0D00) THEN ! ! Cases where the argument is real and negative ! - IF (ARGR <= 0.0D00) THEN + IF (ARGR <= 0.0D00) THEN ! ! Stop with an error message if the argument is too near a pole ! - DIFF = ABS(DBLE(NINT(ARGR)) - ARGR) - IF (DIFF <= PRECIS + PRECIS) THEN - WRITE (*, 300) ARGR, ARGI - STOP - ELSE + DIFF = ABS(DBLE(NINT(ARGR)) - ARGR) + IF (DIFF <= PRECIS + PRECIS) THEN + WRITE (*, 300) ARGR, ARGI + STOP + ELSE ! ! Otherwise use the reflection formula (Abramowitz and Stegun 6.1.17) ! to ensure that the argument is suitable for Stirling's formula ! - ARGUM = PI/(-ARGR*SIN(PI*ARGR)) - IF (ARGUM < 0.0D00) THEN - ARGUM = -ARGUM - CLNGI = PI - ELSE - CLNGI = 0.0D00 - ENDIF - FACNEG = LOG(ARGUM) - ARGUR = -ARGR - NEGARG = .TRUE. + ARGUM = PI/(-ARGR*SIN(PI*ARGR)) + IF (ARGUM < 0.0D00) THEN + ARGUM = -ARGUM + CLNGI = PI + ELSE + CLNGI = 0.0D00 + ENDIF + FACNEG = LOG(ARGUM) + ARGUR = -ARGR + NEGARG = .TRUE. ! - ENDIF + ENDIF ! ! Cases where the argument is real and positive ! - ELSE + ELSE ! - CLNGI = 0.0D00 - ARGUR = ARGR - NEGARG = .FALSE. + CLNGI = 0.0D00 + ARGUR = ARGR + NEGARG = .FALSE. ! - ENDIF + ENDIF ! ! Use Abramowitz and Stegun formula 6.1.15 to ensure that ! the argument in Stirling's formula is greater than 10 ! - OVLFAC = 1.0D00 - 2 CONTINUE - IF (ARGUR < 10.0D00) THEN - OVLFAC = OVLFAC*ARGUR - ARGUR = ARGUR + 1.0D00 - GO TO 2 - ENDIF + OVLFAC = 1.0D00 + 2 CONTINUE + IF (ARGUR < 10.0D00) THEN + OVLFAC = OVLFAC*ARGUR + ARGUR = ARGUR + 1.0D00 + GO TO 2 + ENDIF ! ! Now use Stirling's formula to compute Log (Gamma (ARGUM)) ! - CLNGR = (ARGUR - 0.5D00)*LOG(ARGUR) - ARGUR + HLNTPI - FAC = ARGUR - OBASQ = 1.0D00/(ARGUR*ARGUR) - DO I = 1, 7 - FAC = FAC*OBASQ - CLNGR = CLNGR + FN(I)*FAC - END DO + CLNGR = (ARGUR - 0.5D00)*LOG(ARGUR) - ARGUR + HLNTPI + FAC = ARGUR + OBASQ = 1.0D00/(ARGUR*ARGUR) + DO I = 1, 7 + FAC = FAC*OBASQ + CLNGR = CLNGR + FN(I)*FAC + END DO ! ! Include the contributions from the recurrence and reflection ! formulae ! - CLNGR = CLNGR - LOG(OVLFAC) - IF (NEGARG) CLNGR = FACNEG - CLNGR + CLNGR = CLNGR - LOG(OVLFAC) + IF (NEGARG) CLNGR = FACNEG - CLNGR ! - ELSE + ELSE ! ! Cases where the argument is complex ! - ARGUR = ARGR - ARGUI = ARGI - ARGUI2 = ARGUI*ARGUI + ARGUR = ARGR + ARGUI = ARGI + ARGUI2 = ARGUI*ARGUI ! ! Use the recurrence formula (Abramowitz and Stegun 6.1.15) ! to ensure that the magnitude of the argument in Stirling's ! formula is greater than 10 ! - OVLFR = 1.0D00 - OVLFI = 0.0D00 - 4 CONTINUE - ARGUM = SQRT(ARGUR*ARGUR + ARGUI2) - IF (ARGUM < 10.0D00) THEN - TERMR = OVLFR*ARGUR - OVLFI*ARGUI - TERMI = OVLFR*ARGUI + OVLFI*ARGUR - OVLFR = TERMR - OVLFI = TERMI - ARGUR = ARGUR + 1.0D00 - GO TO 4 - ENDIF + OVLFR = 1.0D00 + OVLFI = 0.0D00 + 4 CONTINUE + ARGUM = SQRT(ARGUR*ARGUR + ARGUI2) + IF (ARGUM < 10.0D00) THEN + TERMR = OVLFR*ARGUR - OVLFI*ARGUI + TERMI = OVLFR*ARGUI + OVLFI*ARGUR + OVLFR = TERMR + OVLFI = TERMI + ARGUR = ARGUR + 1.0D00 + GO TO 4 + ENDIF ! ! Now use Stirling's formula to compute Log (Gamma (ARGUM)) ! - ARGUR2 = ARGUR*ARGUR - TERMR = 0.5D00*LOG(ARGUR2 + ARGUI2) - TERMI = ARCTAN(ARGUI,ARGUR) - CLNGR = (ARGUR - 0.5D00)*TERMR - ARGUI*TERMI - ARGUR + HLNTPI - CLNGI = (ARGUR - 0.5D00)*TERMI + ARGUI*TERMR - ARGUI - FAC = (ARGUR2 + ARGUI2)**(-2) - OBASQR = (ARGUR2 - ARGUI2)*FAC - OBASQI = -2.0D00*ARGUR*ARGUI*FAC - ZFACR = ARGUR - ZFACI = ARGUI - DO I = 1, 7 - TERMR = ZFACR*OBASQR - ZFACI*OBASQI - TERMI = ZFACR*OBASQI + ZFACI*OBASQR - FAC = FN(I) - CLNGR = CLNGR + TERMR*FAC - CLNGI = CLNGI + TERMI*FAC - ZFACR = TERMR - ZFACI = TERMI - END DO + ARGUR2 = ARGUR*ARGUR + TERMR = 0.5D00*LOG(ARGUR2 + ARGUI2) + TERMI = ARCTAN(ARGUI,ARGUR) + CLNGR = (ARGUR - 0.5D00)*TERMR - ARGUI*TERMI - ARGUR + HLNTPI + CLNGI = (ARGUR - 0.5D00)*TERMI + ARGUI*TERMR - ARGUI + FAC = (ARGUR2 + ARGUI2)**(-2) + OBASQR = (ARGUR2 - ARGUI2)*FAC + OBASQI = -2.0D00*ARGUR*ARGUI*FAC + ZFACR = ARGUR + ZFACI = ARGUI + DO I = 1, 7 + TERMR = ZFACR*OBASQR - ZFACI*OBASQI + TERMI = ZFACR*OBASQI + ZFACI*OBASQR + FAC = FN(I) + CLNGR = CLNGR + TERMR*FAC + CLNGI = CLNGI + TERMI*FAC + ZFACR = TERMR + ZFACI = TERMI + END DO ! ! Add in the relevant pieces from the recurrence formula ! - CLNGR = CLNGR - 0.5D00*LOG(OVLFR*OVLFR + OVLFI*OVLFI) - CLNGI = CLNGI - ARCTAN(OVLFI,OVLFR) + CLNGR = CLNGR - 0.5D00*LOG(OVLFR*OVLFR + OVLFI*OVLFI) + CLNGI = CLNGI - ARCTAN(OVLFI,OVLFR) ! - ENDIF + ENDIF ! ! Now exponentiate the complex Log Gamma function to get ! the complex Gamma function ! - IF (CLNGR<=EXPMAX .AND. CLNGR>=EXPMIN) THEN - FAC = EXP(CLNGR) - ELSE - WRITE (*, 301) CLNGR - STOP - ENDIF - RESR = FAC*COS(CLNGI) - RESI = FAC*SIN(CLNGI) + IF (CLNGR<=EXPMAX .AND. CLNGR>=EXPMIN) THEN + FAC = EXP(CLNGR) + ELSE + WRITE (*, 301) CLNGR + STOP + ENDIF + RESR = FAC*COS(CLNGI) + RESI = FAC*SIN(CLNGI) ! - RETURN + RETURN ! 300 FORMAT('CGAMMA: Argument (',1P,1D19.12,',',1D19.12,')',& - ' too close to a pole.') + ' too close to a pole.') 301 FORMAT('CGAMMA: Argument to exponential function',' (',1P,1D19.12,& - ') out of range.') - RETURN + ') out of range.') + RETURN ! - END SUBROUTINE CGAMMA + END SUBROUTINE CGAMMA diff --git a/src/lib/lib9290/cgamma_I.f90 b/src/lib/lib9290/cgamma_I.f90 index 3de4d4d0f..9e4c49b0b 100644 --- a/src/lib/lib9290/cgamma_I.f90 +++ b/src/lib/lib9290/cgamma_I.f90 @@ -1,18 +1,18 @@ - MODULE cgamma_I + MODULE cgamma_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:48 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:48 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cgamma (ARGR, ARGI, RESR, RESI) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: ARGR - REAL(DOUBLE), INTENT(IN) :: ARGI - REAL(DOUBLE), INTENT(OUT) :: RESR - REAL(DOUBLE), INTENT(OUT) :: RESI + SUBROUTINE cgamma (ARGR, ARGI, RESR, RESI) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: ARGR + REAL(DOUBLE), INTENT(IN) :: ARGI + REAL(DOUBLE), INTENT(OUT) :: RESR + REAL(DOUBLE), INTENT(OUT) :: RESI !VAST.../DEF0/ EXPMAX(IN), EXPMIN(IN), PRECIS(IN) !VAST.../DEF9/ PI(IN) !VAST...Calls: ARCTAN !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/clrx.f90 b/src/lib/lib9290/clrx.f90 index 4cd9cf42d..1eaa9a25b 100644 --- a/src/lib/lib9290/clrx.f90 +++ b/src/lib/lib9290/clrx.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION CLRX (KAPPAA, K, KAPPAB) + REAL(KIND(0.0D0)) FUNCTION CLRX (KAPPAA, K, KAPPAB) ! * ! The value of CLRX is the 3-j symbol: * ! * @@ -19,103 +19,103 @@ REAL(KIND(0.0D0)) FUNCTION CLRX (KAPPAA, K, KAPPAB) ! Written by Farid A Parpia, at Oxford Last updated: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE FACTS_C + USE vast_kind_param, ONLY: DOUBLE + USE FACTS_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: KAPPAA, K, KAPPAB + INTEGER, INTENT(IN) :: KAPPAA, K, KAPPAB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: KA, KB, KAPKB, KABKP, KAMKB, KBMKA - REAL(DOUBLE) :: EXPTRM + INTEGER :: KA, KB, KAPKB, KABKP, KAMKB, KBMKA + REAL(DOUBLE) :: EXPTRM !----------------------------------------------- ! ! ! Determine the absolute values of the kappas ! - KA = ABS(KAPPAA) - KB = ABS(KAPPAB) + KA = ABS(KAPPAA) + KB = ABS(KAPPAB) ! ! Perform the triangularity check ! - IF (ABS(KA - KB)<=K .AND. KA+KB-1>=K) THEN + IF (ABS(KA - KB)<=K .AND. KA+KB-1>=K) THEN ! ! Triangularity satisfied; compute the 3j coefficient ! ! Begin with the logarithm of the square of the leading term ! - EXPTRM = -LOG(DBLE(KA*KB)) + EXPTRM = -LOG(DBLE(KA*KB)) ! ! Compute the logarithm of the square root of the leading term ! and the factorial part that doesn't depend on the parity of ! KA+KB+K (the delta factor) ! - KAPKB = KA + KB - KABKP = KAPKB + K - KAMKB = KA - KB - KBMKA = KB - KA + KAPKB = KA + KB + KABKP = KAPKB + K + KAMKB = KA - KB + KBMKA = KB - KA EXPTRM = 0.5D00*(EXPTRM + GAM(KAPKB-K)+GAM(KAMKB+K+1)+GAM(KBMKA+K+1)-& - GAM(KABKP+1)) + GAM(KABKP+1)) ! ! The remainder depends on the parity of KA+KB+K ! - IF (MOD(KABKP,2) == 0) THEN + IF (MOD(KABKP,2) == 0) THEN ! ! Computation for even parity case ! ! Include the phase factor: a minus sign if necessary ! - IF (MOD(3*KABKP/2,2) == 0) THEN - CLRX = 1.0D00 - ELSE - CLRX = -1.0D00 - ENDIF + IF (MOD(3*KABKP/2,2) == 0) THEN + CLRX = 1.0D00 + ELSE + CLRX = -1.0D00 + ENDIF ! ! Include the contribution from the factorials ! EXPTRM = EXPTRM + GAM((KABKP+2)/2) - GAM((KAPKB-K)/2) - GAM((KAMKB+& - K+2)/2) - GAM((KBMKA+K+2)/2) + K+2)/2) - GAM((KBMKA+K+2)/2) ! - ELSE + ELSE ! ! Computation for odd parity case ! ! Include the phase factor: a minus sign if necessary ! - IF (MOD((3*KABKP - 1)/2,2) == 0) THEN - CLRX = 1.0D00 - ELSE - CLRX = -1.0D00 - ENDIF + IF (MOD((3*KABKP - 1)/2,2) == 0) THEN + CLRX = 1.0D00 + ELSE + CLRX = -1.0D00 + ENDIF ! ! Include the contribution from the factorials ! EXPTRM = EXPTRM + GAM((KABKP+1)/2) - GAM((KAPKB-K+1)/2) - GAM((& - KAMKB+K+1)/2) - GAM((KBMKA+K+1)/2) + KAMKB+K+1)/2) - GAM((KBMKA+K+1)/2) ! - ENDIF + ENDIF ! ! Final assembly ! - CLRX = CLRX*EXP(EXPTRM) + CLRX = CLRX*EXP(EXPTRM) ! - ELSE + ELSE ! ! Triangularity violated; set the coefficient to zero ! - CLRX = 0.0D00 + CLRX = 0.0D00 ! - ENDIF + ENDIF ! - RETURN + RETURN ! - END FUNCTION CLRX + END FUNCTION CLRX diff --git a/src/lib/lib9290/clrx_I.f90 b/src/lib/lib9290/clrx_I.f90 index cfbe172df..3217736a8 100644 --- a/src/lib/lib9290/clrx_I.f90 +++ b/src/lib/lib9290/clrx_I.f90 @@ -1,15 +1,15 @@ - MODULE clrx_I + MODULE clrx_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION clrx (KAPPAA, K, KAPPAB) - INTEGER MFACT - PARAMETER(MFACT=500) - INTEGER, INTENT(IN) :: KAPPAA - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: KAPPAB + REAL(KIND(0.0D0)) FUNCTION clrx (KAPPAA, K, KAPPAB) + INTEGER MFACT + PARAMETER(MFACT=500) + INTEGER, INTENT(IN) :: KAPPAA + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: KAPPAB !VAST.../FACTS/ GAM(IN) - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/convrt.f90 b/src/lib/lib9290/convrt.f90 index d927356df..14d9c88c7 100644 --- a/src/lib/lib9290/convrt.f90 +++ b/src/lib/lib9290/convrt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CONVRT(INTNUM, CNUM, LENTH) + SUBROUTINE CONVRT(INTNUM, CNUM, LENTH) ! * ! Converts the INTEGER number INTNUM into the CHARACTER string * ! CNUM of length LENTH. INTEGER lengths of up to 64 bits are acco- * @@ -10,50 +10,50 @@ SUBROUTINE CONVRT(INTNUM, CNUM, LENTH) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INTNUM - INTEGER, INTENT(OUT) :: LENTH - CHARACTER, INTENT(INOUT) :: CNUM*(*) + INTEGER, INTENT(IN) :: INTNUM + INTEGER, INTENT(OUT) :: LENTH + CHARACTER, INTENT(INOUT) :: CNUM*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - CHARACTER(LEN=6) :: FORM - CHARACTER(LEN=2), DIMENSION(0:10) :: C1020 - CHARACTER, DIMENSION(9) :: C19 + CHARACTER(LEN=6) :: FORM + CHARACTER(LEN=2), DIMENSION(0:10) :: C1020 + CHARACTER, DIMENSION(9) :: C19 ! - DATA C19 /'1','2','3','4','5','6','7','8','9'/ + DATA C19 /'1','2','3','4','5','6','7','8','9'/ DATA C1020 /'10','11','12','13','14','15','16','17','18','19','20'/ !----------------------------------------------- - IF (INTNUM < 0) THEN - LENTH = LOG10(DBLE((-INTNUM))) + 2 - ELSE IF (INTNUM == 0) THEN - LENTH = 1 - ELSE - LENTH = LOG10(DBLE(INTNUM)) + 1 - ENDIF + IF (INTNUM < 0) THEN + LENTH = LOG10(DBLE((-INTNUM))) + 2 + ELSE IF (INTNUM == 0) THEN + LENTH = 1 + ELSE + LENTH = LOG10(DBLE(INTNUM)) + 1 + ENDIF ! ! Ensure that the length of CNUM as dimensioned is adequate; ! stop with an error message if it isn't ! - IF (LENTH > LEN(CNUM)) THEN - WRITE (6, *) 'CONVRT: Length of CNUM inadeuate.' - STOP - ELSE - IF (LENTH <= 9) THEN - FORM = '(1I'//C19(LENTH)//')' - WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUM - ELSE - FORM = '(1I'//C1020(LENTH-10)//')' - WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUM - ENDIF - ENDIF + IF (LENTH > LEN(CNUM)) THEN + WRITE (6, *) 'CONVRT: Length of CNUM inadeuate.' + STOP + ELSE + IF (LENTH <= 9) THEN + FORM = '(1I'//C19(LENTH)//')' + WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUM + ELSE + FORM = '(1I'//C1020(LENTH-10)//')' + WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUM + ENDIF + ENDIF ! - RETURN - END SUBROUTINE CONVRT + RETURN + END SUBROUTINE CONVRT diff --git a/src/lib/lib9290/convrt2.f90 b/src/lib/lib9290/convrt2.f90 index f0e60c8c9..a60cf3ee3 100644 --- a/src/lib/lib9290/convrt2.f90 +++ b/src/lib/lib9290/convrt2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CONVRT2(INTNUM, CNUM, LENTH, FROM) + SUBROUTINE CONVRT2(INTNUM, CNUM, LENTH, FROM) ! * ! Converts the INTEGER number INTNUM into the CHARACTER string * ! CNUM of length LENTH. INTEGER lengths of up to 64 bits are acco- * @@ -9,56 +9,56 @@ SUBROUTINE CONVRT2(INTNUM, CNUM, LENTH, FROM) ! Written by Farid A. Parpia Last revision: 22 Sep 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:54 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:54 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE IOUNIT_C + USE IOUNIT_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INTNUM - INTEGER, INTENT(OUT) :: LENTH - CHARACTER, INTENT(INOUT) :: CNUM*(*) - CHARACTER, INTENT(IN) :: FROM*(*) + INTEGER, INTENT(IN) :: INTNUM + INTEGER, INTENT(OUT) :: LENTH + CHARACTER, INTENT(INOUT) :: CNUM*(*) + CHARACTER, INTENT(IN) :: FROM*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - CHARACTER :: FORM*6 - CHARACTER, DIMENSION(0:10) :: C1020*2 - CHARACTER, DIMENSION(9) :: C19 + CHARACTER :: FORM*6 + CHARACTER, DIMENSION(0:10) :: C1020*2 + CHARACTER, DIMENSION(9) :: C19 ! ! - DATA C19/ '1', '2', '3', '4', '5', '6', '7', '8', '9'/ + DATA C19/ '1', '2', '3', '4', '5', '6', '7', '8', '9'/ DATA C1020/ '10', '11', '12', '13', '14', '15', '16', '17', '18', '19', & - '20'/ + '20'/ ! - IF (INTNUM < 0) THEN - LENTH = LOG10(DBLE((-INTNUM))) + 2 - ELSE IF (INTNUM == 0) THEN - LENTH = 1 - ELSE - LENTH = LOG10(DBLE(INTNUM)) + 1 - ENDIF + IF (INTNUM < 0) THEN + LENTH = LOG10(DBLE((-INTNUM))) + 2 + ELSE IF (INTNUM == 0) THEN + LENTH = 1 + ELSE + LENTH = LOG10(DBLE(INTNUM)) + 1 + ENDIF ! ! Ensure that the length of CNUM as dimensioned is adequate; ! stop with an error message if it isn't ! - IF (LENTH > LEN(CNUM)) THEN - WRITE (ISTDE, *) 'CONVRT: Length of CNUM inadeuate. (from:', FROM, ')' - STOP - ELSE - IF (LENTH <= 9) THEN - FORM = '(1I'//C19(LENTH)//')' - WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUM - ELSE - FORM = '(1I'//C1020(LENTH-10)//')' - WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUM - ENDIF - ENDIF + IF (LENTH > LEN(CNUM)) THEN + WRITE (ISTDE, *) 'CONVRT: Length of CNUM inadeuate. (from:', FROM, ')' + STOP + ELSE + IF (LENTH <= 9) THEN + FORM = '(1I'//C19(LENTH)//')' + WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUM + ELSE + FORM = '(1I'//C1020(LENTH-10)//')' + WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUM + ENDIF + ENDIF ! - RETURN - END SUBROUTINE CONVRT2 + RETURN + END SUBROUTINE CONVRT2 diff --git a/src/lib/lib9290/convrt2_I.f90 b/src/lib/lib9290/convrt2_I.f90 index 61f7b9f67..c06f5f75e 100644 --- a/src/lib/lib9290/convrt2_I.f90 +++ b/src/lib/lib9290/convrt2_I.f90 @@ -1,15 +1,15 @@ - MODULE convrt2_I + MODULE convrt2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:54 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:54 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE convrt2 (INTNUM, CNUM, LENTH, FROM) - INTEGER, INTENT(IN) :: INTNUM - CHARACTER (LEN = *), INTENT(INOUT) :: CNUM - INTEGER, INTENT(OUT) :: LENTH - CHARACTER (LEN = *), INTENT(IN) :: FROM + SUBROUTINE convrt2 (INTNUM, CNUM, LENTH, FROM) + INTEGER, INTENT(IN) :: INTNUM + CHARACTER (LEN = *), INTENT(INOUT) :: CNUM + INTEGER, INTENT(OUT) :: LENTH + CHARACTER (LEN = *), INTENT(IN) :: FROM !VAST.../IOUNIT/ ISTDE(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/convrt_I.f90 b/src/lib/lib9290/convrt_I.f90 index 50b2f4042..1fe7bc83d 100644 --- a/src/lib/lib9290/convrt_I.f90 +++ b/src/lib/lib9290/convrt_I.f90 @@ -1,13 +1,13 @@ - MODULE convrt_I + MODULE convrt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE convrt (INTNUM, CNUM, LENTH) - INTEGER, INTENT(IN) :: INTNUM - CHARACTER (LEN = *), INTENT(INOUT) :: CNUM - INTEGER, INTENT(OUT) :: LENTH + SUBROUTINE convrt (INTNUM, CNUM, LENTH) + INTEGER, INTENT(IN) :: INTNUM + CHARACTER (LEN = *), INTENT(INOUT) :: CNUM + INTEGER, INTENT(OUT) :: LENTH !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/convrt_double.f90 b/src/lib/lib9290/convrt_double.f90 index 8ef87bfa6..3b6a32d72 100644 --- a/src/lib/lib9290/convrt_double.f90 +++ b/src/lib/lib9290/convrt_double.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) + SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) ! * ! Converts the INTEGER number INTNUM into the CHARACTER string * ! CNUM of length LENTH. INTEGER lengths of up to 64 bits are acco- * @@ -9,8 +9,8 @@ SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) ! Written by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !==================================================================== @@ -19,57 +19,57 @@ SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: INTNUM - INTEGER, INTENT(OUT) :: LENTH - CHARACTER, INTENT(INOUT) :: CNUM*(*) + INTEGER, INTENT(IN) :: INTNUM + INTEGER, INTENT(OUT) :: LENTH + CHARACTER, INTENT(INOUT) :: CNUM*(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: INTNUMGG CHARACTER(LEN=6) :: FORM - CHARACTER(LEN=2), DIMENSION(0:10) :: C1020 - CHARACTER, DIMENSION(9) :: C19 + CHARACTER(LEN=2), DIMENSION(0:10) :: C1020 + CHARACTER, DIMENSION(9) :: C19 ! - DATA C19 /'1','2','3','4','5','6','7','8','9'/ + DATA C19 /'1','2','3','4','5','6','7','8','9'/ DATA C1020 /'10','11','12','13','14','15','16','17','18','19','20'/ !----------------------------------------------- IF(mod(INTNUM,2) == 0) THEN INTNUMGG = INTNUM/2 ELSE INTNUMGG = INTNUM - ENDIF + ENDIF ! - IF (INTNUMGG < 0) THEN - LENTH = LOG10(DBLE((-INTNUMGG))) + 2 - ELSE IF (INTNUMGG == 0) THEN - LENTH = 1 - ELSE - LENTH = LOG10(DBLE(INTNUMGG)) + 1 - ENDIF + IF (INTNUMGG < 0) THEN + LENTH = LOG10(DBLE((-INTNUMGG))) + 2 + ELSE IF (INTNUMGG == 0) THEN + LENTH = 1 + ELSE + LENTH = LOG10(DBLE(INTNUMGG)) + 1 + ENDIF ! ! Ensure that the length of CNUM as dimensioned is adequate; ! stop with an error message if it isn't ! - IF (LENTH > LEN(CNUM)) THEN - WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' - STOP - ELSE - IF (LENTH <= 9) THEN - FORM = '(1I'//C19(LENTH)//')' - WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUMGG - ELSE - FORM = '(1I'//C1020(LENTH-10)//')' - WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUMGG - ENDIF + IF (LENTH > LEN(CNUM)) THEN + WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' + STOP + ELSE + IF (LENTH <= 9) THEN + FORM = '(1I'//C19(LENTH)//')' + WRITE (CNUM(1:LENTH), FORM(1:5)) INTNUMGG + ELSE + FORM = '(1I'//C1020(LENTH-10)//')' + WRITE (CNUM(1:LENTH), FORM(1:6)) INTNUMGG + ENDIF IF(mod(INTNUM,2) /= 0) THEN - IF (LENTH+2 > LEN(CNUM)) THEN - WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' - STOP + IF (LENTH+2 > LEN(CNUM)) THEN + WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' + STOP ELSE CNUM(1:LENTH+2) = CNUM(1:LENTH)//'/2' LENTH = LENTH + 2 - ENDIF - ENDIF - ENDIF - RETURN - END SUBROUTINE CONVRT_DOUBLE + ENDIF + ENDIF + ENDIF + RETURN + END SUBROUTINE CONVRT_DOUBLE diff --git a/src/lib/lib9290/convrt_double_I.f90 b/src/lib/lib9290/convrt_double_I.f90 index 1bdc23839..c120323a9 100644 --- a/src/lib/lib9290/convrt_double_I.f90 +++ b/src/lib/lib9290/convrt_double_I.f90 @@ -1,13 +1,13 @@ - MODULE convrt_DOUBLE_I + MODULE convrt_DOUBLE_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:53 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE convrt_double (INTNUM, CNUM, LENTH) - INTEGER, INTENT(IN) :: INTNUM - CHARACTER (LEN = *), INTENT(INOUT) :: CNUM - INTEGER, INTENT(OUT) :: LENTH + SUBROUTINE convrt_double (INTNUM, CNUM, LENTH) + INTEGER, INTENT(IN) :: INTNUM + CHARACTER (LEN = *), INTENT(INOUT) :: CNUM + INTEGER, INTENT(OUT) :: LENTH !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/cord.f90 b/src/lib/lib9290/cord.f90 index 008744923..501478f1d 100644 --- a/src/lib/lib9290/cord.f90 +++ b/src/lib/lib9290/cord.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE CORD(JA, JB, JA1, IPCA, JB1) + SUBROUTINE CORD(JA, JB, JA1, IPCA, JB1) !----------------------------------------------- ! * ! Computes the MCP coefficients for contributions involving closed * @@ -13,20 +13,20 @@ SUBROUTINE CORD(JA, JB, JA1, IPCA, JB1) ! Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:57 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:57 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE ORB_C USE M_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE speak_I - USE clrx_I + USE speak_I + USE clrx_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -34,80 +34,80 @@ SUBROUTINE CORD(JA, JB, JA1, IPCA, JB1) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 + INTEGER :: JA + INTEGER :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: EPS = 1.0D-10 + REAL(DOUBLE), PARAMETER :: EPS = 1.0D-10 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IA1,IB1,NS,KAP1,J1,NQS1,NUMAX,NU,KAP2,J2,NQS2,NUMIN - REAL(DOUBLE) :: X,CONST,GAM + INTEGER :: IA1,IB1,NS,KAP1,J1,NQS1,NUMAX,NU,KAP2,J2,NQS2,NUMIN + REAL(DOUBLE) :: X,CONST,GAM !----------------------------------------------- ! ! ! Set quantum numbers required. ! - IF (IPCA == 2) THEN - IA1 = KLIST(JA1) - ELSE - IA1 = JLIST(JA1) - ENDIF - IB1 = KLIST(JB1) + IF (IPCA == 2) THEN + IA1 = KLIST(JA1) + ELSE + IA1 = JLIST(JA1) + ENDIF + IB1 = KLIST(JB1) ! ! Force IA1 to be greater than IB1 ! - IF (IA1 > IB1) THEN - NS = IA1 - IA1 = IB1 - IB1 = NS - ENDIF + IF (IA1 > IB1) THEN + NS = IA1 + IA1 = IB1 + IB1 = NS + ENDIF ! - KAP1 = NAK(IA1) - J1 = IABS(KAP1) - NQS1 = NQ1(IA1) + KAP1 = NAK(IA1) + J1 = IABS(KAP1) + NQS1 = NQ1(IA1) ! - IF (IA1 == IB1) THEN + IF (IA1 == IB1) THEN ! ! Case when IA1 .EQ. IB1 ! - X = DBLE(NQS1*(NQS1 - 1)/2) - CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, 0, X) - NUMAX = J1 + J1 - 2 - IF (NUMAX <= 0) RETURN - CONST = DBLE(NQS1*NQS1/2) - DO NU = 2, NUMAX, 2 - GAM = CLRX(KAP1,NU,KAP1) - X = -CONST*GAM*GAM - IF (ABS(X) < EPS) CYCLE - CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, NU, X) - END DO + X = DBLE(NQS1*(NQS1 - 1)/2) + CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, 0, X) + NUMAX = J1 + J1 - 2 + IF (NUMAX <= 0) RETURN + CONST = DBLE(NQS1*NQS1/2) + DO NU = 2, NUMAX, 2 + GAM = CLRX(KAP1,NU,KAP1) + X = -CONST*GAM*GAM + IF (ABS(X) < EPS) CYCLE + CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, NU, X) + END DO ! ! Case when IA1 .NE. IB1 ! - ELSE + ELSE ! - KAP2 = NAK(IB1) - J2 = ABS(KAP2) - NQS2 = NQ1(IB1) - CONST = DBLE(NQS1*NQS2) - CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, 0, CONST) - NUMIN = ABS(J1 - J2) - NUMAX = J1 + J2 - 1 - IF (KAP1*KAP2 < 0) NUMIN = NUMIN + 1 - DO NU = NUMIN, NUMAX, 2 - GAM = CLRX(KAP1,NU,KAP2) - X = -CONST*GAM*GAM - IF (ABS(X) < EPS) CYCLE - CALL SPEAK (JA, JB, IA1, IB1, IB1, IA1, NU, X) - END DO + KAP2 = NAK(IB1) + J2 = ABS(KAP2) + NQS2 = NQ1(IB1) + CONST = DBLE(NQS1*NQS2) + CALL SPEAK (JA, JB, IA1, IB1, IA1, IB1, 0, CONST) + NUMIN = ABS(J1 - J2) + NUMAX = J1 + J2 - 1 + IF (KAP1*KAP2 < 0) NUMIN = NUMIN + 1 + DO NU = NUMIN, NUMAX, 2 + GAM = CLRX(KAP1,NU,KAP2) + X = -CONST*GAM*GAM + IF (ABS(X) < EPS) CYCLE + CALL SPEAK (JA, JB, IA1, IB1, IB1, IA1, NU, X) + END DO ! - ENDIF + ENDIF ! - RETURN - END SUBROUTINE CORD + RETURN + END SUBROUTINE CORD diff --git a/src/lib/lib9290/cord_I.f90 b/src/lib/lib9290/cord_I.f90 index 1c73e7691..e70c6a355 100644 --- a/src/lib/lib9290/cord_I.f90 +++ b/src/lib/lib9290/cord_I.f90 @@ -1,18 +1,18 @@ - MODULE cord_I + MODULE cord_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:57 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:57 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cord (JA, JB, JA1, IPCA, JB1) - INTEGER :: JA - INTEGER :: JB - INTEGER, INTENT(IN) :: JA1 - INTEGER, INTENT(IN) :: IPCA - INTEGER, INTENT(IN) :: JB1 + SUBROUTINE cord (JA, JB, JA1, IPCA, JB1) + INTEGER :: JA + INTEGER :: JB + INTEGER, INTENT(IN) :: JA1 + INTEGER, INTENT(IN) :: IPCA + INTEGER, INTENT(IN) :: JB1 !VAST.../ORB4/ NAK(IN) !VAST.../M1/ NQ1(IN) !VAST.../M3/ JLIST(IN), KLIST(IN) !VAST...Calls: SPEAK, CLRX - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/count.f90 b/src/lib/lib9290/count.f90 index b5037f420..8026df4d7 100644 --- a/src/lib/lib9290/count.f90 +++ b/src/lib/lib9290/count.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE COUNT(FR, MTPFR, NNCFF, SGN) + SUBROUTINE COUNT(FR, MTPFR, NNCFF, SGN) ! * ! This subroutine counts the nodes in the radial function FR using * ! the criteria given by C Froese Fischer, Comp Phys Rep, 3 (1986) * @@ -11,92 +11,92 @@ SUBROUTINE COUNT(FR, MTPFR, NNCFF, SGN) ! Written by Farid A Parpia, at Oxford Last update: 08 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:58 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:46:58 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- * -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE COUN_C - USE DEF_C, ONLY: ACCY - USE GRID_C + USE COUN_C + USE DEF_C, ONLY: ACCY + USE GRID_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MTPFR - INTEGER, INTENT(OUT) :: NNCFF - REAL(DOUBLE), INTENT(OUT) :: SGN + INTEGER, INTENT(IN) :: MTPFR + INTEGER, INTENT(OUT) :: NNCFF + REAL(DOUBLE), INTENT(OUT) :: SGN REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: FR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNP) :: LCEXT - INTEGER :: NEXT, I, LOC, NSTPS - REAL(DOUBLE) :: EXT, EMX, ABFRI, TEST, THRESE, ABLCL + INTEGER, DIMENSION(NNNP) :: LCEXT + INTEGER :: NEXT, I, LOC, NSTPS + REAL(DOUBLE) :: EXT, EMX, ABFRI, TEST, THRESE, ABLCL !----------------------------------------------- ! ! ! (1) Find all extrema in FR ! (2) Find the maximum amplitudes of FR ! - NEXT = 1 - EXT = 0.0D00 - LCEXT(1) = 1 - EMX = 0.0D00 - DO I = 2, MTPFR - ABFRI = ABS(FR(I)) - TEST = ABS(SIGN(1.0D00,FR(I))+SIGN(1.0D00,FR(I-1))) - IF (TEST <= ACCY) THEN - NEXT = NEXT + 1 - LCEXT(NEXT) = 0 - EXT = 0.0D00 - ENDIF - IF (ABFRI > EXT) THEN - EXT = ABFRI - LCEXT(NEXT) = I - ENDIF - IF (ABFRI <= EMX) CYCLE - EMX = ABFRI - END DO + NEXT = 1 + EXT = 0.0D00 + LCEXT(1) = 1 + EMX = 0.0D00 + DO I = 2, MTPFR + ABFRI = ABS(FR(I)) + TEST = ABS(SIGN(1.0D00,FR(I))+SIGN(1.0D00,FR(I-1))) + IF (TEST <= ACCY) THEN + NEXT = NEXT + 1 + LCEXT(NEXT) = 0 + EXT = 0.0D00 + ENDIF + IF (ABFRI > EXT) THEN + EXT = ABFRI + LCEXT(NEXT) = I + ENDIF + IF (ABFRI <= EMX) CYCLE + EMX = ABFRI + END DO ! ! Eliminate oscillations with amplitude less than THRESH times ! the maximum ! - LOC = 0 - THRESE = THRESH*EMX - 4 CONTINUE - LOC = LOC + 1 - IF (LOC <= NEXT) THEN - IF (LCEXT(LOC) == 0) THEN - ABLCL = 0.0D00 - ELSE - ABLCL = ABS(FR(LCEXT(LOC))) - ENDIF - IF (ABLCL < THRESE) THEN - NEXT = NEXT - 1 - NSTPS = NEXT - LOC - LCEXT(LOC:NSTPS+LOC) = LCEXT(LOC+1:NSTPS+1+LOC) - LOC = LOC - 1 - ENDIF - GO TO 4 - ENDIF + LOC = 0 + THRESE = THRESH*EMX + 4 CONTINUE + LOC = LOC + 1 + IF (LOC <= NEXT) THEN + IF (LCEXT(LOC) == 0) THEN + ABLCL = 0.0D00 + ELSE + ABLCL = ABS(FR(LCEXT(LOC))) + ENDIF + IF (ABLCL < THRESE) THEN + NEXT = NEXT - 1 + NSTPS = NEXT - LOC + LCEXT(LOC:NSTPS+LOC) = LCEXT(LOC+1:NSTPS+1+LOC) + LOC = LOC - 1 + ENDIF + GO TO 4 + ENDIF ! ! Count changes of sign using the remaining oscillations ! - NNCFF = 0 - DO I = 2, NEXT - TEST = ABS(SIGN(1.0D00,FR(LCEXT(I)))+SIGN(1.0D00,FR(LCEXT(I-1)))) - IF (TEST > ACCY) CYCLE - NNCFF = NNCFF + 1 - END DO + NNCFF = 0 + DO I = 2, NEXT + TEST = ABS(SIGN(1.0D00,FR(LCEXT(I)))+SIGN(1.0D00,FR(LCEXT(I-1)))) + IF (TEST > ACCY) CYCLE + NNCFF = NNCFF + 1 + END DO ! ! Determine the position of the first oscillation, and the ! sign of the function at this location ! - SGN = SIGN(1.0D00,FR(LCEXT(1))) + SGN = SIGN(1.0D00,FR(LCEXT(1))) ! - RETURN - END SUBROUTINE COUNT + RETURN + END SUBROUTINE COUNT diff --git a/src/lib/lib9290/count_I.f90 b/src/lib/lib9290/count_I.f90 index 39fb43204..a4e63d974 100644 --- a/src/lib/lib9290/count_I.f90 +++ b/src/lib/lib9290/count_I.f90 @@ -1,17 +1,17 @@ - MODULE count_I + MODULE count_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:58 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:46:58 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE count (FR, MTPFR, NNCFF, SGN) - USE vast_kind_param, ONLY: DOUBLE + SUBROUTINE count (FR, MTPFR, NNCFF, SGN) + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: FR - INTEGER, INTENT(IN) :: MTPFR - INTEGER, INTENT(OUT) :: NNCFF - REAL(DOUBLE), INTENT(OUT) :: SGN + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: FR + INTEGER, INTENT(IN) :: MTPFR + INTEGER, INTENT(OUT) :: NNCFF + REAL(DOUBLE), INTENT(OUT) :: SGN !VAST.../COUN/ THRESH(IN) !VAST.../DEF4/ ACCY(IN) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/cre.f90 b/src/lib/lib9290/cre.f90 index 8d7b82090..d577e8fc0 100644 --- a/src/lib/lib9290/cre.f90 +++ b/src/lib/lib9290/cre.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION CRE (KAP1, K, KAP2) + REAL(KIND(0.0D0)) FUNCTION CRE (KAP1, K, KAP2) !----------------------------------------------- ! * ! Computes the relativistic reduced matrix element * @@ -16,35 +16,35 @@ REAL(KIND(0.0D0)) FUNCTION CRE (KAP1, K, KAP2) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:10 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:10 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE clrx_I + USE clrx_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: KAP1 - INTEGER :: K - INTEGER :: KAP2 + INTEGER :: KAP1 + INTEGER :: K + INTEGER :: KAP2 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K1 - REAL(DOUBLE) :: DK1K2 + INTEGER :: K1 + REAL(DOUBLE) :: DK1K2 !----------------------------------------------- ! - K1 = ABS(KAP1) - DK1K2 = DBLE(4*K1*IABS(KAP2)) - CRE = SQRT(DK1K2)*CLRX(KAP1,K,KAP2) - IF (MOD(K1,2) == 1) CRE = -CRE + K1 = ABS(KAP1) + DK1K2 = DBLE(4*K1*IABS(KAP2)) + CRE = SQRT(DK1K2)*CLRX(KAP1,K,KAP2) + IF (MOD(K1,2) == 1) CRE = -CRE ! - RETURN - END FUNCTION CRE + RETURN + END FUNCTION CRE diff --git a/src/lib/lib9290/cre_I.f90 b/src/lib/lib9290/cre_I.f90 index c10fe1f8a..f91550370 100644 --- a/src/lib/lib9290/cre_I.f90 +++ b/src/lib/lib9290/cre_I.f90 @@ -1,13 +1,13 @@ - MODULE cre_I + MODULE cre_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:10 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:10 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION cre (KAP1, K, KAP2) - INTEGER, INTENT(IN) :: KAP1 - INTEGER :: K - INTEGER, INTENT(IN) :: KAP2 + REAL(KIND(0.0D0)) FUNCTION cre (KAP1, K, KAP2) + INTEGER, INTENT(IN) :: KAP1 + INTEGER :: K + INTEGER, INTENT(IN) :: KAP2 !VAST...Calls: CLRX - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/cslh.f90 b/src/lib/lib9290/cslh.f90 index 1a3e819a8..c74cfc77b 100644 --- a/src/lib/lib9290/cslh.f90 +++ b/src/lib/lib9290/cslh.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE CSLH(NAME, NCORE, NBLKIN, IDBLK) + SUBROUTINE CSLH(NAME, NCORE, NBLKIN, IDBLK) ! A container which calls setcsll to open, read file to get ! nblock, ncfblk(), idblk(), ncftot. ! It then calls lib92/lodcsh to get @@ -12,49 +12,49 @@ SUBROUTINE CSLH(NAME, NCORE, NBLKIN, IDBLK) ! Xinghong He 98-06-23 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:12 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:12 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man - USE HBLOCK_C - USE DEF_C - USE ORB_C, NCFTOT=>NCF + USE HBLOCK_C + USE DEF_C + USE ORB_C, NCFTOT=>NCF ! !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE setcsll_I - USE lodcsh_I + USE setcsll_I + USE lodcsh_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE - INTEGER :: NBLKIN - CHARACTER :: NAME*(*) - CHARACTER :: IDBLK(*)*8 + INTEGER :: NCORE + INTEGER :: NBLKIN + CHARACTER :: NAME*(*) + CHARACTER :: IDBLK(*)*8 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IQADUM - INTEGER :: IERR + INTEGER :: IQADUM + INTEGER :: IERR !----------------------------------------------- ! - + ! node-0 does exactly the same as the serial code does - - CALL ALLOC (NCFBLK, NBLKIN + 1, 'NCFBLK', 'CSLH') - CALL SETCSLL (21, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) - CALL RALLOC (NCFBLK, NBLOCK + 1, 'NCFBLK', 'CSLH') - REWIND (21) - READ (21, *) + CALL ALLOC (NCFBLK, NBLKIN + 1, 'NCFBLK', 'CSLH') + + CALL SETCSLL (21, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) + CALL RALLOC (NCFBLK, NBLOCK + 1, 'NCFBLK', 'CSLH') + REWIND (21) + READ (21, *) !..Load header of file - CALL LODCSH (21, NCORE) - - RETURN - END SUBROUTINE CSLH + CALL LODCSH (21, NCORE) + + RETURN + END SUBROUTINE CSLH diff --git a/src/lib/lib9290/cslh_I.f90 b/src/lib/lib9290/cslh_I.f90 index 07fb3e22c..13935d381 100644 --- a/src/lib/lib9290/cslh_I.f90 +++ b/src/lib/lib9290/cslh_I.f90 @@ -1,17 +1,17 @@ - MODULE cslh_I + MODULE cslh_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:12 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:12 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cslh (NAME, NCORE, NBLKIN, IDBLK) - CHARACTER (LEN = *) :: NAME - INTEGER :: NCORE - INTEGER, INTENT(IN) :: NBLKIN - CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK + SUBROUTINE cslh (NAME, NCORE, NBLKIN, IDBLK) + CHARACTER (LEN = *) :: NAME + INTEGER :: NCORE + INTEGER, INTENT(IN) :: NBLKIN + CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK !VAST.../HBLOCK/ NBLOCK(INOUT), PNCFBLK(INOUT) !VAST.../ORB2/ NCFTOT(INOUT) !VAST...Calls: ALLOC, SETCSLL, NCFBLK, RALLOC, LODCSH !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/dcbsrw.f90 b/src/lib/lib9290/dcbsrw.f90 index 87cc91168..00bffe96b 100644 --- a/src/lib/lib9290/dcbsrw.f90 +++ b/src/lib/lib9290/dcbsrw.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DCBSRW(N, KAPPA, Z, E, RG0, RG, RF, MTP) + SUBROUTINE DCBSRW(N, KAPPA, Z, E, RG0, RG, RF, MTP) ! * ! This subroutine computes the Dirac-Coulomb bound-state orbital * ! radial wavefunction. Equations (13.5) and (13.5') of Akhiezer * @@ -27,224 +27,224 @@ SUBROUTINE DCBSRW(N, KAPPA, Z, E, RG0, RG, RF, MTP) ! Written by Farid A Parpia, at Oxford Last Update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE DEF_C , ONLY: C, ACCY - USE GRID_C, ONLY: R, NTP=>N - USE TATB_C, ONLY: TA, TB + USE GRID_C, ONLY: R, NTP=>N + USE TATB_C, ONLY: TA, TB !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE cgamma_I + USE cgamma_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - INTEGER, INTENT(OUT) :: MTP - REAL(DOUBLE), INTENT(IN) :: Z - REAL(DOUBLE), INTENT(OUT) :: E - REAL(DOUBLE), INTENT(OUT) :: RG0 + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + INTEGER, INTENT(OUT) :: MTP + REAL(DOUBLE), INTENT(IN) :: Z + REAL(DOUBLE), INTENT(OUT) :: E + REAL(DOUBLE), INTENT(OUT) :: RG0 REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: RG REAL(DOUBLE), DIMENSION(NNNP), INTENT(OUT) :: RF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, NR, NRFAC, I, IORDR1, IORDR2 + INTEGER :: K, NR, NRFAC, I, IORDR1, IORDR2 REAL(DOUBLE) :: ALFA, FN, FKAPPA, FK, FNR, ZALFA, GAMMA, TWOGP1, BIGN, & EPS, ARGR, ARGI, RGAMM1, DUMMY, RGAMM2, FAC, FG, FF, FACN, A, AN1, AN2& - , B, BN, FDEN, BIGNMK, RHO, RHON, F1, F2, OVLFAC, CUTOFF + , B, BN, FDEN, BIGNMK, RHO, RHON, F1, F2, OVLFAC, CUTOFF !----------------------------------------------- ! ! ! ! Ensure that the principal quantum number is physical ! - IF (N <= 0) THEN - WRITE (*, 300) - WRITE (*, 301) N - STOP - ENDIF + IF (N <= 0) THEN + WRITE (*, 300) + WRITE (*, 301) N + STOP + ENDIF ! ! Ensure that the angular quantum number is physical ! - IF (KAPPA == 0) THEN - WRITE (*, 300) - WRITE (*, 302) - STOP - ELSE IF (KAPPA == N) THEN - WRITE (*, 300) - WRITE (*, 303) KAPPA, N - STOP - ELSE IF (ABS(KAPPA) > N) THEN - WRITE (*, 300) - WRITE (*, 303) KAPPA, N - STOP - ENDIF + IF (KAPPA == 0) THEN + WRITE (*, 300) + WRITE (*, 302) + STOP + ELSE IF (KAPPA == N) THEN + WRITE (*, 300) + WRITE (*, 303) KAPPA, N + STOP + ELSE IF (ABS(KAPPA) > N) THEN + WRITE (*, 300) + WRITE (*, 303) KAPPA, N + STOP + ENDIF ! ! Ensure that the charge is physical ! - IF (Z <= 0.0D00) THEN - WRITE (*, 300) - WRITE (*, 304) Z - STOP - ELSE IF (Z > C) THEN - WRITE (*, 300) - WRITE (*, 305) Z, C - STOP - ENDIF + IF (Z <= 0.0D00) THEN + WRITE (*, 300) + WRITE (*, 304) Z + STOP + ELSE IF (Z > C) THEN + WRITE (*, 300) + WRITE (*, 305) Z, C + STOP + ENDIF ! ! Atomic units ! - ALFA = 1.0D00/C + ALFA = 1.0D00/C ! ! Now determine all the parameters ! - FN = DBLE(N) - FKAPPA = DBLE(KAPPA) - K = ABS(KAPPA) - FK = DBLE(K) - NR = N - K - FNR = DBLE(NR) - ZALFA = Z*ALFA - GAMMA = SQRT(FK*FK - ZALFA*ZALFA) - TWOGP1 = GAMMA + GAMMA + 1.0D00 - BIGN = SQRT(FN*FN - 2.0D00*FNR*(FK - GAMMA)) - EPS = 1.0D00/SQRT(1.0D00 + (ZALFA/(GAMMA + FNR))**2) + FN = DBLE(N) + FKAPPA = DBLE(KAPPA) + K = ABS(KAPPA) + FK = DBLE(K) + NR = N - K + FNR = DBLE(NR) + ZALFA = Z*ALFA + GAMMA = SQRT(FK*FK - ZALFA*ZALFA) + TWOGP1 = GAMMA + GAMMA + 1.0D00 + BIGN = SQRT(FN*FN - 2.0D00*FNR*(FK - GAMMA)) + EPS = 1.0D00/SQRT(1.0D00 + (ZALFA/(GAMMA + FNR))**2) ! ! EPS is the total energy divided by C*C; this must be converted ! to the units and reference energy of GRASP ! - E = (1.0D00 - EPS)*C*C + E = (1.0D00 - EPS)*C*C ! ! Now the normalization constants ! - NRFAC = 1 - DO I = 1, NR - NRFAC = NRFAC*I - END DO + NRFAC = 1 + DO I = 1, NR + NRFAC = NRFAC*I + END DO ! - ARGR = TWOGP1 + FNR - ARGI = 0.0D00 - CALL CGAMMA (ARGR, ARGI, RGAMM1, DUMMY) - ARGR = TWOGP1 - CALL CGAMMA (ARGR, ARGI, RGAMM2, DUMMY) + ARGR = TWOGP1 + FNR + ARGI = 0.0D00 + CALL CGAMMA (ARGR, ARGI, RGAMM1, DUMMY) + ARGR = TWOGP1 + CALL CGAMMA (ARGR, ARGI, RGAMM2, DUMMY) ! FAC = -SQRT(RGAMM1)/(RGAMM2*SQRT(DBLE(NRFAC)))*SQRT(Z/(2.0D00*BIGN*BIGN*(& - BIGN - FKAPPA))) + BIGN - FKAPPA))) ! ! Ensure that the slope of the large-component function is ! positive at the origin ! - IF (KAPPA > 0) FAC = -FAC + IF (KAPPA > 0) FAC = -FAC ! - FG = FAC*SQRT(1.0D00 + EPS) - FF = FAC*SQRT(1.0D00 - EPS) + FG = FAC*SQRT(1.0D00 + EPS) + FF = FAC*SQRT(1.0D00 - EPS) ! ! Now set up the coefficients of the confluent hypergeometric ! functions F (-NR+1,2*GAMMA+1;RHO) and F (-NR,2*GAMMA+1;RHO) ! in the workspace arrays TA and TB , respectively ! - IF (NR == 0) THEN - IORDR1 = 0 - IORDR2 = 0 - ELSE - IORDR1 = NR - 1 - IORDR2 = NR - ENDIF -! - FAC = 1.0D00 - FACN = 1.0D00 - A = -FNR - AN1 = A + 1.0D00 - AN2 = A - B = TWOGP1 - BN = B -! - K = 0 - 2 CONTINUE - K = K + 1 - FDEN = 1.0D00/(FACN*BN) - IF (K <= IORDR1) TA(K) = AN1*FDEN - IF (K <= IORDR2) THEN - TB(K) = AN2*FDEN - A = A + 1.0D00 - AN1 = AN1*(A + 1.0D00) - AN2 = AN2*A - B = B + 1.0D00 - BN = BN*B - FAC = FAC + 1.0D00 - FACN = FACN*FAC - GO TO 2 - ENDIF + IF (NR == 0) THEN + IORDR1 = 0 + IORDR2 = 0 + ELSE + IORDR1 = NR - 1 + IORDR2 = NR + ENDIF +! + FAC = 1.0D00 + FACN = 1.0D00 + A = -FNR + AN1 = A + 1.0D00 + AN2 = A + B = TWOGP1 + BN = B +! + K = 0 + 2 CONTINUE + K = K + 1 + FDEN = 1.0D00/(FACN*BN) + IF (K <= IORDR1) TA(K) = AN1*FDEN + IF (K <= IORDR2) THEN + TB(K) = AN2*FDEN + A = A + 1.0D00 + AN1 = AN1*(A + 1.0D00) + AN2 = AN2*A + B = B + 1.0D00 + BN = BN*B + FAC = FAC + 1.0D00 + FACN = FACN*FAC + GO TO 2 + ENDIF ! ! Now tabulate the function over the entire grid ! - RG(1) = 0.0D00 - RF(1) = 0.0D00 - FAC = (Z + Z)/BIGN - BIGNMK = BIGN - FKAPPA - DO I = 2, NTP - RHO = FAC*R(I) - RHON = RHO - K = 0 - F1 = 1.0D00 - F2 = 1.0D00 - 3 CONTINUE - K = K + 1 - IF (K <= IORDR1) F1 = F1 + TA(K)*RHON - IF (K <= IORDR2) THEN - F2 = F2 + TB(K)*RHON - RHON = RHON*RHO - GO TO 3 - ENDIF - F1 = FNR*F1 - F2 = BIGNMK*F2 - OVLFAC = EXP((-0.5D00*RHO))*RHO**GAMMA - RG(I) = FG*OVLFAC*(F1 - F2) - RF(I) = FF*OVLFAC*(F1 + F2) - END DO + RG(1) = 0.0D00 + RF(1) = 0.0D00 + FAC = (Z + Z)/BIGN + BIGNMK = BIGN - FKAPPA + DO I = 2, NTP + RHO = FAC*R(I) + RHON = RHO + K = 0 + F1 = 1.0D00 + F2 = 1.0D00 + 3 CONTINUE + K = K + 1 + IF (K <= IORDR1) F1 = F1 + TA(K)*RHON + IF (K <= IORDR2) THEN + F2 = F2 + TB(K)*RHON + RHON = RHON*RHO + GO TO 3 + ENDIF + F1 = FNR*F1 + F2 = BIGNMK*F2 + OVLFAC = EXP((-0.5D00*RHO))*RHO**GAMMA + RG(I) = FG*OVLFAC*(F1 - F2) + RF(I) = FF*OVLFAC*(F1 + F2) + END DO ! ! Determine the effective maximum tabulation point based on the ! cutoff; define the cutoff conservatively ! - CUTOFF = ACCY*0.1D00 + CUTOFF = ACCY*0.1D00 ! - MTP = NTP + 1 - 5 CONTINUE - MTP = MTP - 1 + MTP = NTP + 1 + 5 CONTINUE + MTP = MTP - 1 ! IF (ABS(RG(MTP)) < CUTOFF) THEN IF ((ABS(RG(MTP)) < CUTOFF).OR.(ABS(R(MTP)) > 1.D+50)) THEN ! JE: APPLY BOX (R<1.D+50) - RG(MTP) = 0.0D00 - RF(MTP) = 0.0D00 - GO TO 5 - ENDIF + RG(MTP) = 0.0D00 + RF(MTP) = 0.0D00 + GO TO 5 + ENDIF ! - IF (MTP == NTP) WRITE (*, 306) NTP, RG(NTP), CUTOFF + IF (MTP == NTP) WRITE (*, 306) NTP, RG(NTP), CUTOFF ! ! Compute the coefficient of R**GAMMA at the origin ! - RG0 = FG*FAC**GAMMA*(FNR - BIGNMK) + RG0 = FG*FAC**GAMMA*(FNR - BIGNMK) ! - RETURN + RETURN ! - 300 FORMAT('DCBSRW:') - 301 FORMAT(' Principal quantum number is ',1I3) - 302 FORMAT(' Angular quantum number is 0') + 300 FORMAT('DCBSRW:') + 301 FORMAT(' Principal quantum number is ',1I3) + 302 FORMAT(' Angular quantum number is 0') 303 FORMAT(' Angular quantum number (',1I3,') is out of range for',& - ' principal quantum number (',1I3,')') - 304 FORMAT(' Nuclear charge (',3P,1D16.7,') is too small') - 305 FORMAT(' Nuclear charge (',3P,1D16.7,') exceeds C (',1D16.7,')') + ' principal quantum number (',1I3,')') + 304 FORMAT(' Nuclear charge (',3P,1D16.7,') is too small') + 305 FORMAT(' Nuclear charge (',3P,1D16.7,') exceeds C (',1D16.7,')') 306 FORMAT(/,/,/,' ***** Warning in SUBROUTINE DCBSRW *****'/,/,& ' Radial grid of insufficient extent:'/,' P(',1I4,') = ',1P,1D10.3,& - ', Exceeds cutoff (',1D10.3,')') - RETURN + ', Exceeds cutoff (',1D10.3,')') + RETURN ! - END SUBROUTINE DCBSRW + END SUBROUTINE DCBSRW diff --git a/src/lib/lib9290/dcbsrw_I.f90 b/src/lib/lib9290/dcbsrw_I.f90 index 548f46472..5e2e0fb66 100644 --- a/src/lib/lib9290/dcbsrw_I.f90 +++ b/src/lib/lib9290/dcbsrw_I.f90 @@ -1,25 +1,25 @@ - MODULE dcbsrw_I + MODULE dcbsrw_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:15 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:15 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dcbsrw (N, KAPPA, Z, E, RG0, RG, RF, MTP) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE dcbsrw (N, KAPPA, Z, E, RG0, RG, RF, MTP) + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KAPPA - REAL(DOUBLE), INTENT(IN) :: Z - REAL(DOUBLE), INTENT(OUT) :: E - REAL(DOUBLE), INTENT(OUT) :: RG0 - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: RG - REAL(DOUBLE), DIMENSION(NNNP), INTENT(OUT) :: RF - INTEGER, INTENT(OUT) :: MTP + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KAPPA + REAL(DOUBLE), INTENT(IN) :: Z + REAL(DOUBLE), INTENT(OUT) :: E + REAL(DOUBLE), INTENT(OUT) :: RG0 + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: RG + REAL(DOUBLE), DIMENSION(NNNP), INTENT(OUT) :: RF + INTEGER, INTENT(OUT) :: MTP !VAST.../DEF2/ C(IN) !VAST.../DEF4/ ACCY(IN) !VAST.../GRID/ R(IN), NTP(IN) !VAST.../TATB/ TA(INOUT), TB(INOUT) !VAST...Calls: CGAMMA !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/dinit.f90 b/src/lib/lib9290/dinit.f90 index e73775ebc..8ab4b8bdd 100644 --- a/src/lib/lib9290/dinit.f90 +++ b/src/lib/lib9290/dinit.f90 @@ -1,4 +1,4 @@ - SUBROUTINE DINIT(N, A, X, INCX) + SUBROUTINE DINIT(N, A, X, INCX) ! ================================================================== ! ! PURPOSE ... INITIALIZES REAL*8 VECTOR TO @@ -7,48 +7,48 @@ SUBROUTINE DINIT(N, A, X, INCX) ! CREATED ... APR. 14, 1987 ! ! ================================================================== -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:18 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:18 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: INCX - REAL(DOUBLE), INTENT(IN) :: A + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: INCX + REAL(DOUBLE), INTENT(IN) :: A REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: X !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: XADDR, I + INTEGER :: XADDR, I !----------------------------------------------- ! - IF (INCX == 1) THEN + IF (INCX == 1) THEN ! ! ---------------------------------- ! ... UNIT INCREMENT (STANDARD CASE) ! ---------------------------------- ! - X(:N) = A + X(:N) = A ! - ELSE + ELSE ! ! ---------------------- ! ... NON-UNIT INCREMENT ! ---------------------- ! - XADDR = 1 - IF (INCX < 0) XADDR = ((-N) + 1)*INCX + 1 + XADDR = 1 + IF (INCX < 0) XADDR = ((-N) + 1)*INCX + 1 ! - X(XADDR:(N-1)*INCX+XADDR:INCX) = A + X(XADDR:(N-1)*INCX+XADDR:INCX) = A ! - ENDIF + ENDIF ! - RETURN + RETURN ! - END SUBROUTINE DINIT + END SUBROUTINE DINIT diff --git a/src/lib/lib9290/dinit_I.f90 b/src/lib/lib9290/dinit_I.f90 index 4e3669584..4092db12f 100644 --- a/src/lib/lib9290/dinit_I.f90 +++ b/src/lib/lib9290/dinit_I.f90 @@ -1,14 +1,14 @@ - MODULE dinit_I + MODULE dinit_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:18 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:18 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dinit (N, A, X, INCX) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: A - REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: X - INTEGER, INTENT(IN) :: INCX - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dinit (N, A, X, INCX) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: A + REAL(DOUBLE), DIMENSION(*), INTENT(OUT) :: X + INTEGER, INTENT(IN) :: INCX + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/dmerge.f90 b/src/lib/lib9290/dmerge.f90 index 4d49c45da..a3dadc116 100644 --- a/src/lib/lib9290/dmerge.f90 +++ b/src/lib/lib9290/dmerge.f90 @@ -1,26 +1,26 @@ !************************************************************************** ! - SUBROUTINE DMERGE(N, DB, DC, IDY, DA, DCONST, DL) + SUBROUTINE DMERGE(N, DB, DC, IDY, DA, DCONST, DL) !----------------------------------------------- ! ! this merge version has the advantage of loading da(i) ! and idy(i) only once. ! !************************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:20 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:20 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(IN) :: DCONST - REAL(DOUBLE), INTENT(OUT) :: DL + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(IN) :: DCONST + REAL(DOUBLE), INTENT(OUT) :: DL INTEGER, DIMENSION(N), INTENT(IN) :: IDY REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC @@ -28,16 +28,16 @@ SUBROUTINE DMERGE(N, DB, DC, IDY, DA, DCONST, DL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DSUM -!----------------------------------------------- - - DSUM = 0.0 - DO I = 1, N - DSUM = DSUM + DA(I)*DB(IDY(I)) - DC(IDY(I)) = DC(IDY(I)) + DCONST*DA(I) - END DO - DL = DSUM - - RETURN - END SUBROUTINE DMERGE + INTEGER :: I + REAL(DOUBLE) :: DSUM +!----------------------------------------------- + + DSUM = 0.0 + DO I = 1, N + DSUM = DSUM + DA(I)*DB(IDY(I)) + DC(IDY(I)) = DC(IDY(I)) + DCONST*DA(I) + END DO + DL = DSUM + + RETURN + END SUBROUTINE DMERGE diff --git a/src/lib/lib9290/dmerge_I.f90 b/src/lib/lib9290/dmerge_I.f90 index 9651c8ebf..5ada5ef9c 100644 --- a/src/lib/lib9290/dmerge_I.f90 +++ b/src/lib/lib9290/dmerge_I.f90 @@ -1,17 +1,17 @@ - MODULE dmerge_I + MODULE dmerge_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:20 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:20 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dmerge (N, DB, DC, IDY, DA, DCONST, DL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB - REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC - INTEGER, DIMENSION(N), INTENT(IN) :: IDY - REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA - REAL(DOUBLE), INTENT(IN) :: DCONST - REAL(DOUBLE), INTENT(OUT) :: DL - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE dmerge (N, DB, DC, IDY, DA, DCONST, DL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: DB + REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: DC + INTEGER, DIMENSION(N), INTENT(IN) :: IDY + REAL(DOUBLE), DIMENSION(N), INTENT(IN) :: DA + REAL(DOUBLE), INTENT(IN) :: DCONST + REAL(DOUBLE), INTENT(OUT) :: DL + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/dpbdt.f90 b/src/lib/lib9290/dpbdt.f90 index a939db262..a641e8ce3 100644 --- a/src/lib/lib9290/dpbdt.f90 +++ b/src/lib/lib9290/dpbdt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DPBDT(J) + SUBROUTINE DPBDT(J) !----------------------------------------------- ! * ! This subroutine computes H times the derivative, with respect to * @@ -14,27 +14,27 @@ SUBROUTINE DPBDT(J) ! Written by Farid F Parpia, at Oxford Last updated: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE GRID_C - USE LIC13_C + USE vast_kind_param, ONLY: DOUBLE + USE GRID_C + USE LIC13_C USE TATB_C, ONLY: TA, TB - USE WAVE_C + USE WAVE_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J + INTEGER :: J !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, K, IROW, LOC - REAL(DOUBLE) :: A1, A2, A3, A4, A5, A6, HDPBDT, HDQBDT, AIK + INTEGER :: I, K, IROW, LOC + REAL(DOUBLE) :: A1, A2, A3, A4, A5, A6, HDPBDT, HDQBDT, AIK !----------------------------------------------- ! @@ -71,33 +71,33 @@ SUBROUTINE DPBDT(J) ! Special treatment for this region because of the symmetry of ! the differentiation formula ! - DO I = 7, N - 6 + DO I = 7, N - 6 TA(I) = A1*(PF(I - 6,J) - PF(I + 6,J)) + A2*(PF(I - 5,J) - PF(I + 5,J)& ) + A3*(PF(I - 4,J) - PF(I + 4,J)) + A4*(PF(I - 3,J) - PF(I + 3,J))& - + A5*(PF(I - 2,J) - PF(I + 2,J)) + A6*(PF(I - 1,J) - PF(I + 1,J)) + + A5*(PF(I - 2,J) - PF(I + 2,J)) + A6*(PF(I - 1,J) - PF(I + 1,J)) TB(I) = A1*(QF(I - 6,J) - QF(I + 6,J)) + A2*(QF(I - 5,J) - QF(I + 5,J)& ) + A3*(QF(I - 4,J) - QF(I + 4,J)) + A4*(QF(I - 3,J) - QF(I + 3,J))& - + A5*(QF(I - 2,J) - QF(I + 2,J)) + A6*(QF(I - 1,J) - QF(I + 1,J)) - END DO + + A5*(QF(I - 2,J) - QF(I + 2,J)) + A6*(QF(I - 1,J) - QF(I + 1,J)) + END DO ! ! Last, points N-5 to N ! - DO I = N - 5, N - IROW = I - N + 13 + DO I = N - 5, N + IROW = I - N + 13 HDPBDT = SUM(A(IROW,:)*PF(N-12:N,J)) HDQBDT = SUM(A(IROW,:)*QF(N-12:N,J)) !- git 1/12/07 code below from the new libraries -! HDPBDT = 0.D0 -! HDQBDT = 0.D0 -! DO K = 1, 13 -! AIK = A(IROW,K) -! LOC = N - 13 + K -! HDPBDT = HDPBDT + AIK*PF(LOC,J) -! HDQBDT = HDQBDT + AIK*QF(LOC,J) -! END DO +! HDPBDT = 0.D0 +! HDQBDT = 0.D0 +! DO K = 1, 13 +! AIK = A(IROW,K) +! LOC = N - 13 + K +! HDPBDT = HDPBDT + AIK*PF(LOC,J) +! HDQBDT = HDQBDT + AIK*QF(LOC,J) +! END DO !- git 1/12/07 - TA(I) = HDPBDT - TB(I) = HDQBDT - END DO - RETURN - END SUBROUTINE DPBDT + TA(I) = HDPBDT + TB(I) = HDQBDT + END DO + RETURN + END SUBROUTINE DPBDT diff --git a/src/lib/lib9290/dpbdt_I.f90 b/src/lib/lib9290/dpbdt_I.f90 index a40a13fcd..5b7d16546 100644 --- a/src/lib/lib9290/dpbdt_I.f90 +++ b/src/lib/lib9290/dpbdt_I.f90 @@ -1,14 +1,14 @@ - MODULE dpbdt_I + MODULE dpbdt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE dpbdt (J) - INTEGER :: J + SUBROUTINE dpbdt (J) + INTEGER :: J !VAST.../GRID/ N(IN) !VAST.../LIC13/ A(IN) !VAST.../TATB/ TA(OUT), TB(OUT) !VAST...Calls: PF, QF - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/draw.f90 b/src/lib/lib9290/draw.f90 index c8c08e5dc..7609f8b22 100644 --- a/src/lib/lib9290/draw.f90 +++ b/src/lib/lib9290/draw.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DRAW(P, SP, Q, SQ, MF) + SUBROUTINE DRAW(P, SP, Q, SQ, MF) ! * ! This subroutine generates a printer plot. P and Q are radial * ! functions with the maximum tabulation point MF. SP is the factor * @@ -10,145 +10,145 @@ SUBROUTINE DRAW(P, SP, Q, SQ, MF) ! Written by Farid A Parpia, at Oxford Last revision: 10 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE GRID_C + USE GRID_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MF - REAL(DOUBLE), INTENT(IN) :: SP - REAL(DOUBLE), INTENT(IN) :: SQ + INTEGER, INTENT(IN) :: MF + REAL(DOUBLE), INTENT(IN) :: SP + REAL(DOUBLE), INTENT(IN) :: SQ REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, IOFFST, IXLOCQ, IXLOCP, IYLOC + INTEGER :: I, IOFFST, IXLOCQ, IXLOCP, IYLOC REAL(DOUBLE) :: SIXTY, FIFT4, OHTHT, DMX, DMN, SPI, SQI, RMX, XSCAL, & - YSCAL, SQX, SPX - LOGICAL :: FIRST - CHARACTER :: CBLANK*132, CDASH*132 + YSCAL, SQX, SPX + LOGICAL :: FIRST + CHARACTER :: CBLANK*132, CDASH*132 !cjb -! CHARACTER , DIMENSION(60) :: CPLOT*132 +! CHARACTER , DIMENSION(60) :: CPLOT*132 CHARACTER , DIMENSION(MF) :: CPLOT*132 !cjb - CHARACTER :: CP, CQ + CHARACTER :: CP, CQ !----------------------------------------------- - DATA SIXTY/ 60.0D00/ - DATA FIFT4/ 54.0D00/ - DATA OHTHT/ 131.0D00/ + DATA SIXTY/ 60.0D00/ + DATA FIFT4/ 54.0D00/ + DATA OHTHT/ 131.0D00/ ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! This initialization is carried out once per run ! - IF (FIRST) THEN - CBLANK(1:1) = '|' - CDASH(1:1) = '-' - DO I = 2, 131 - CBLANK(I:I) = ' ' - CDASH(I:I) = '-' - END DO - CBLANK(132:132) = '|' - CDASH(132:132) = '-' - FIRST = .FALSE. - ENDIF + IF (FIRST) THEN + CBLANK(1:1) = '|' + CDASH(1:1) = '-' + DO I = 2, 131 + CBLANK(I:I) = ' ' + CDASH(I:I) = '-' + END DO + CBLANK(132:132) = '|' + CDASH(132:132) = '-' + FIRST = .FALSE. + ENDIF ! ! Initialization ! - IF (SQ == 0.0D00) THEN - CP = 'X' - CQ = '-' - ELSE - CP = 'P' - CQ = 'Q' - ENDIF + IF (SQ == 0.0D00) THEN + CP = 'X' + CQ = '-' + ELSE + CP = 'P' + CQ = 'Q' + ENDIF ! ! Determine the range of amplitude ! - DMX = MAX(SP*P(1),SQ*Q(1)) - DMN = MIN(SP*P(1),SQ*Q(1)) - DO I = 2, MF - SPI = SP*P(I) - SQI = SQ*Q(I) - DMX = MAX(MAX(DMX,SPI),SQI) - DMN = MIN(MIN(DMN,SPI),SQI) - END DO + DMX = MAX(SP*P(1),SQ*Q(1)) + DMN = MIN(SP*P(1),SQ*Q(1)) + DO I = 2, MF + SPI = SP*P(I) + SQI = SQ*Q(I) + DMX = MAX(MAX(DMX,SPI),SQI) + DMN = MIN(MIN(DMN,SPI),SQI) + END DO ! ! Determine the radial extent of the function ! - RMX = R(MF) + RMX = R(MF) ! ! Determine the scale factors ! - IF (DMX==0.0D00 .AND. DMN==0.0D00) THEN - WRITE (99, 300) - RETURN - ELSE - XSCAL = FIFT4/ABS(DMX - DMN) - ENDIF - YSCAL = OHTHT/DBLE(N) + IF (DMX==0.0D00 .AND. DMN==0.0D00) THEN + WRITE (99, 300) + RETURN + ELSE + XSCAL = FIFT4/ABS(DMX - DMN) + ENDIF + YSCAL = OHTHT/DBLE(N) ! ! Locate x = 0 if this is in the range ! - IF (DMX>0.0D00 .AND. DMN<0.0D00) THEN - IOFFST = 4 + XSCAL*ABS(DMN) - ELSE - IOFFST = 1 - ENDIF + IF (DMX>0.0D00 .AND. DMN<0.0D00) THEN + IOFFST = 4 + XSCAL*ABS(DMN) + ELSE + IOFFST = 1 + ENDIF ! ! Initialize the array CPLOT ! - DO I = 1, 60 - IF (I==1 .OR. I==IOFFST .OR. I==60) THEN - CPLOT(I) = CDASH - ELSE - CPLOT(I) = CBLANK - ENDIF - END DO + DO I = 1, 60 + IF (I==1 .OR. I==IOFFST .OR. I==60) THEN + CPLOT(I) = CDASH + ELSE + CPLOT(I) = CBLANK + ENDIF + END DO ! ! Generate the plot ! ! Note that 'P' is the dominant character ! - SQX = SQ*XSCAL - SPX = SP*XSCAL - DO I = 1, MF - IXLOCQ = NINT(SQX*Q(I)) + IOFFST - IXLOCP = NINT(SPX*P(I)) + IOFFST - IYLOC = MAX(1,NINT(DBLE(I)*YSCAL)) - CPLOT(IXLOCQ)(IYLOC:IYLOC) = CQ - CPLOT(IXLOCP)(IYLOC:IYLOC) = CP - END DO + SQX = SQ*XSCAL + SPX = SP*XSCAL + DO I = 1, MF + IXLOCQ = NINT(SQX*Q(I)) + IOFFST + IXLOCP = NINT(SPX*P(I)) + IOFFST + IYLOC = MAX(1,NINT(DBLE(I)*YSCAL)) + CPLOT(IXLOCQ)(IYLOC:IYLOC) = CQ + CPLOT(IXLOCP)(IYLOC:IYLOC) = CP + END DO ! ! Print plot ! - WRITE (99, 301) - DO I = 60, 1, -1 - WRITE (99, 302) CPLOT(I) - END DO + WRITE (99, 301) + DO I = 60, 1, -1 + WRITE (99, 302) CPLOT(I) + END DO ! ! Plot-information line ! - WRITE (99, 303) RMX, DMX + WRITE (99, 303) RMX, DMX ! - RETURN + RETURN ! - 300 FORMAT(' No plot: function is identically zero') - 301 FORMAT('1') - 302 FORMAT(1X,1A132) + 300 FORMAT(' No plot: function is identically zero') + 301 FORMAT('1') + 302 FORMAT(1X,1A132) 303 FORMAT(/,50X,1P,' r (max) = ',1D10.3,'Bohr radii,',& - ' Maximum of functions = ',1D10.3) - RETURN + ' Maximum of functions = ',1D10.3) + RETURN ! - END SUBROUTINE DRAW + END SUBROUTINE DRAW diff --git a/src/lib/lib9290/draw_I.f90 b/src/lib/lib9290/draw_I.f90 index 9f31b87fb..5dde6a4d2 100644 --- a/src/lib/lib9290/draw_I.f90 +++ b/src/lib/lib9290/draw_I.f90 @@ -1,18 +1,18 @@ - MODULE draw_I + MODULE draw_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE draw (P, SP, Q, SQ, MF) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE draw (P, SP, Q, SQ, MF) + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P - REAL(DOUBLE), INTENT(IN) :: SP - REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q - REAL(DOUBLE), INTENT(IN) :: SQ - INTEGER, INTENT(IN) :: MF + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: P + REAL(DOUBLE), INTENT(IN) :: SP + REAL(DOUBLE), DIMENSION(NNNP), INTENT(IN) :: Q + REAL(DOUBLE), INTENT(IN) :: SQ + INTEGER, INTENT(IN) :: MF !VAST.../GRID/ R(IN), N(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/es.f90 b/src/lib/lib9290/es.f90 index 43bc91b18..48d854ec7 100644 --- a/src/lib/lib9290/es.f90 +++ b/src/lib/lib9290/es.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ES(F, S2F, S3F) + SUBROUTINE ES(F, S2F, S3F) ! * ! Evaluate the sum of the series * ! * @@ -14,53 +14,53 @@ SUBROUTINE ES(F, S2F, S3F) ! Written by Farid A Parpia, at Oxford Last revision: 28 Sep 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:25 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE), INTENT(IN) :: F - REAL(DOUBLE), INTENT(OUT) :: S2F - REAL(DOUBLE), INTENT(OUT) :: S3F + REAL(DOUBLE), INTENT(IN) :: F + REAL(DOUBLE), INTENT(OUT) :: S2F + REAL(DOUBLE), INTENT(OUT) :: S3F !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: N - REAL(DOUBLE) :: FASE, EN, OBN, ENF, TERM2, TERM3, S2LAST + INTEGER :: N + REAL(DOUBLE) :: FASE, EN, OBN, ENF, TERM2, TERM3, S2LAST !----------------------------------------------- ! - N = 0 - S2F = 0.0D00 - S3F = 0.0D00 - FASE = 1.0D00 - N = N + 1 - EN = DBLE(N) - OBN = 1.0D00/EN - FASE = -FASE - ENF = EXP(EN*F) - TERM2 = FASE*ENF*OBN*OBN - TERM3 = TERM2*OBN - S2LAST = S2F - S2F = S2F + TERM2 - S3F = S3F + TERM3 - DO WHILE(ABS(S2F) /= ABS(S2LAST)) - N = N + 1 - EN = DBLE(N) - OBN = 1.0D00/EN - FASE = -FASE - ENF = EXP(EN*F) - TERM2 = FASE*ENF*OBN*OBN - TERM3 = TERM2*OBN - S2LAST = S2F - S2F = S2F + TERM2 - S3F = S3F + TERM3 - END DO + N = 0 + S2F = 0.0D00 + S3F = 0.0D00 + FASE = 1.0D00 + N = N + 1 + EN = DBLE(N) + OBN = 1.0D00/EN + FASE = -FASE + ENF = EXP(EN*F) + TERM2 = FASE*ENF*OBN*OBN + TERM3 = TERM2*OBN + S2LAST = S2F + S2F = S2F + TERM2 + S3F = S3F + TERM3 + DO WHILE(ABS(S2F) /= ABS(S2LAST)) + N = N + 1 + EN = DBLE(N) + OBN = 1.0D00/EN + FASE = -FASE + ENF = EXP(EN*F) + TERM2 = FASE*ENF*OBN*OBN + TERM3 = TERM2*OBN + S2LAST = S2F + S2F = S2F + TERM2 + S3F = S3F + TERM3 + END DO ! - RETURN - END SUBROUTINE ES + RETURN + END SUBROUTINE ES diff --git a/src/lib/lib9290/es_I.f90 b/src/lib/lib9290/es_I.f90 index 9d0a35e86..835115bb4 100644 --- a/src/lib/lib9290/es_I.f90 +++ b/src/lib/lib9290/es_I.f90 @@ -1,13 +1,13 @@ - MODULE es_I + MODULE es_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:25 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE es (F, S2F, S3F) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(IN) :: F - REAL(DOUBLE), INTENT(OUT) :: S2F - REAL(DOUBLE), INTENT(OUT) :: S3F - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE es (F, S2F, S3F) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(IN) :: F + REAL(DOUBLE), INTENT(OUT) :: S2F + REAL(DOUBLE), INTENT(OUT) :: S3F + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/factt.f90 b/src/lib/lib9290/factt.f90 index 7a5329330..f8d7dbb34 100644 --- a/src/lib/lib9290/factt.f90 +++ b/src/lib/lib9290/factt.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE FACTT + SUBROUTINE FACTT ! * ! Calculates the logs of factorials required by the Racah coeffi- * ! cient routine DRACAH. * @@ -9,14 +9,14 @@ SUBROUTINE FACTT ! * !*********************************************************************** ! -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:26 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:47:26 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE FACTS_C + USE vast_kind_param, ONLY: DOUBLE + USE FACTS_C IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -24,29 +24,29 @@ SUBROUTINE FACTT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: X + INTEGER :: I + REAL(DOUBLE) :: X !----------------------------------------------- ! - GAM(1) = 1.0D00 + GAM(1) = 1.0D00 GAM(2) = 1.0D00 - X = 2.0D00 + X = 2.0D00 ! - DO I = 3, 30 - GAM(I) = GAM(I-1)*X - X = X + 1.0D00 - END DO + DO I = 3, 30 + GAM(I) = GAM(I-1)*X + X = X + 1.0D00 + END DO ! - DO I = 1, 30 - GAM(I) = LOG(GAM(I)) - END DO + DO I = 1, 30 + GAM(I) = LOG(GAM(I)) + END DO ! - X = 3.0D01 + X = 3.0D01 ! - DO I = 31, MFACT - GAM(I) = GAM(I-1) + LOG(X) - X = X + 1.0D00 - END DO + DO I = 31, MFACT + GAM(I) = GAM(I-1) + LOG(X) + X = X + 1.0D00 + END DO ! - RETURN - END SUBROUTINE FACTT + RETURN + END SUBROUTINE FACTT diff --git a/src/lib/lib9290/factt_I.f90 b/src/lib/lib9290/factt_I.f90 index 9e07a6f62..7fd8e92b0 100644 --- a/src/lib/lib9290/factt_I.f90 +++ b/src/lib/lib9290/factt_I.f90 @@ -1,10 +1,10 @@ - MODULE factt_I + MODULE factt_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:26 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:47:26 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE factt + SUBROUTINE factt !VAST.../FACTS/ GAM(INOUT) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/getrsl.f90 b/src/lib/lib9290/getrsl.f90 index 6808d491f..51b1acb76 100644 --- a/src/lib/lib9290/getrsl.f90 +++ b/src/lib/lib9290/getrsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE GETRSL(INDX, NSUBS) + SUBROUTINE GETRSL(INDX, NSUBS) ! * ! READs and parses a list of relativistic subshell labels delimit- * ! ed either by blanks or by commas. An asterisk may be used as the * @@ -16,154 +16,154 @@ SUBROUTINE GETRSL(INDX, NSUBS) ! Modified by Xinghong He Last revised: 09 Jul 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:14 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:14 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE ORB_C - USE IOUNIT_C + USE ORB_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ldigit_I - USE convrt_I + USE ldigit_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: NSUBS + INTEGER, INTENT(OUT) :: NSUBS INTEGER, DIMENSION(*), INTENT(INOUT) :: INDX !----------------------------------------------- ! C o m m o n B l o c k s !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISTART, I, IEND, NFORM, J, LENTH, IOS, NPQ, K - LOGICAL :: FOUND, NLANY, NLOK, NPANY, NPOK, NSANY, NSOK - CHARACTER :: NLQ, NSQ, RECI, CNUM*2, FORM*5, RECORD*500 + INTEGER :: ISTART, I, IEND, NFORM, J, LENTH, IOS, NPQ, K + LOGICAL :: FOUND, NLANY, NLOK, NPANY, NPOK, NSANY, NSOK + CHARACTER :: NLQ, NSQ, RECI, CNUM*2, FORM*5, RECORD*500 !----------------------------------------------- ! ! - - GO TO 2 - - 1 CONTINUE - WRITE (ISTDE, *) ' redo ...' + + GO TO 2 + + 1 CONTINUE + WRITE (ISTDE, *) ' redo ...' ! ! Read a record ! - 2 CONTINUE - NSUBS = 0 - READ (*, '(A)') RECORD + 2 CONTINUE + NSUBS = 0 + READ (*, '(A)') RECORD WRITE(734,'(a)') trim(record) ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - 3 CONTINUE - RECI = RECORD(I:I) - IF (RECI/=' ' .AND. RECI/=',') THEN - IF (ISTART == 0) ISTART = I - ELSE - IF (ISTART /= 0) THEN - IEND = I - 1 + ISTART = 0 + I = 1 + 3 CONTINUE + RECI = RECORD(I:I) + IF (RECI/=' ' .AND. RECI/=',') THEN + IF (ISTART == 0) ISTART = I + ELSE + IF (ISTART /= 0) THEN + IEND = I - 1 ! ! Parse the substring from left to right ! ! (1) Determine the principal quantum number ! - IF (RECORD(ISTART:ISTART) == '*') THEN - NPANY = .TRUE. - ISTART = MIN(ISTART + 1,IEND) - ELSE - NPANY = .FALSE. - NFORM = 0 - DO J = ISTART, IEND - IF (.NOT.LDIGIT(RECORD(J:J))) CYCLE - NFORM = NFORM + 1 - END DO - IF (NFORM == 0) THEN + IF (RECORD(ISTART:ISTART) == '*') THEN + NPANY = .TRUE. + ISTART = MIN(ISTART + 1,IEND) + ELSE + NPANY = .FALSE. + NFORM = 0 + DO J = ISTART, IEND + IF (.NOT.LDIGIT(RECORD(J:J))) CYCLE + NFORM = NFORM + 1 + END DO + IF (NFORM == 0) THEN WRITE (ISTDE, *) 'GETRSL: Unable to interpret ', & - 'the principal quantum number;' - GO TO 1 - ENDIF - CALL CONVRT (NFORM, CNUM, LENTH) - FORM = '(1I'//CNUM(1:LENTH)//')' - READ (RECORD(ISTART:ISTART+NFORM-1), FORM, IOSTAT=IOS) NPQ - IF (IOS /= 0) THEN + 'the principal quantum number;' + GO TO 1 + ENDIF + CALL CONVRT (NFORM, CNUM, LENTH) + FORM = '(1I'//CNUM(1:LENTH)//')' + READ (RECORD(ISTART:ISTART+NFORM-1), FORM, IOSTAT=IOS) NPQ + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'GETRSL: Unable to interpret ', 'string ', & - RECORD(ISTART:IEND-2), ' as a principal quantum number' - GO TO 1 - ENDIF - ISTART = ISTART + NFORM - ENDIF + RECORD(ISTART:IEND-2), ' as a principal quantum number' + GO TO 1 + ENDIF + ISTART = ISTART + NFORM + ENDIF ! ! (2) Determine the orbital angular momentum quantum number ! - NLQ = RECORD(ISTART:ISTART) - IF (NLQ == '*') THEN - NLANY = .TRUE. - ELSE - NLANY = .FALSE. - ENDIF + NLQ = RECORD(ISTART:ISTART) + IF (NLQ == '*') THEN + NLANY = .TRUE. + ELSE + NLANY = .FALSE. + ENDIF ! ! (3) Determine the spin-orbit component ! - IF (IEND > ISTART) THEN - NSQ = RECORD(IEND:IEND) - IF (NSQ == '*') THEN - NSANY = .TRUE. - ELSE IF (NSQ == '-') THEN - NSANY = .FALSE. - ELSE + IF (IEND > ISTART) THEN + NSQ = RECORD(IEND:IEND) + IF (NSQ == '*') THEN + NSANY = .TRUE. + ELSE IF (NSQ == '-') THEN + NSANY = .FALSE. + ELSE WRITE (ISTDE, *) 'GETRSL: Unable to interpret ', 'string ', & - NSQ, ' as a spin-orbit component indicator' - GO TO 1 - ENDIF - ELSE - IF (NLANY) THEN - NSANY = .TRUE. - ELSE - NSANY = .FALSE. - NSQ = ' ' - ENDIF - ENDIF -! -! - FOUND = .FALSE. - DO J = 1, NW - NPOK = NPANY .OR. NP(J)==NPQ - NLOK = NLANY .OR. NLQ==NH(J)(1:1) - NSOK = NSANY .OR. NSQ==NH(J)(2:2) - IF (.NOT.(NPOK .AND. NLOK .AND. NSOK)) CYCLE - DO K = 1, NSUBS - IF (INDX(K) /= J) CYCLE - WRITE (ISTDE, *) 'GETRSL: ', 'Repeated subshell in list;' - GO TO 1 - END DO - FOUND = .TRUE. - NSUBS = NSUBS + 1 - INDX(NSUBS) = J - END DO -! - IF (.NOT.FOUND) THEN + NSQ, ' as a spin-orbit component indicator' + GO TO 1 + ENDIF + ELSE + IF (NLANY) THEN + NSANY = .TRUE. + ELSE + NSANY = .FALSE. + NSQ = ' ' + ENDIF + ENDIF +! +! + FOUND = .FALSE. + DO J = 1, NW + NPOK = NPANY .OR. NP(J)==NPQ + NLOK = NLANY .OR. NLQ==NH(J)(1:1) + NSOK = NSANY .OR. NSQ==NH(J)(2:2) + IF (.NOT.(NPOK .AND. NLOK .AND. NSOK)) CYCLE + DO K = 1, NSUBS + IF (INDX(K) /= J) CYCLE + WRITE (ISTDE, *) 'GETRSL: ', 'Repeated subshell in list;' + GO TO 1 + END DO + FOUND = .TRUE. + NSUBS = NSUBS + 1 + INDX(NSUBS) = J + END DO +! + IF (.NOT.FOUND) THEN WRITE (ISTDE, *) 'GETRSL: Subshell not occupied as ', & - ' according to CSL File;' - GO TO 1 - ENDIF + ' according to CSL File;' + GO TO 1 + ENDIF ! - ISTART = 0 - ENDIF - ENDIF + ISTART = 0 + ENDIF + ENDIF ! - IF (I < 500) THEN - I = I + 1 - GO TO 3 - ENDIF + IF (I < 500) THEN + I = I + 1 + GO TO 3 + ENDIF ! - RETURN - END SUBROUTINE GETRSL + RETURN + END SUBROUTINE GETRSL diff --git a/src/lib/lib9290/getrsl_I.f90 b/src/lib/lib9290/getrsl_I.f90 index d4cf19c3a..e77c73659 100644 --- a/src/lib/lib9290/getrsl_I.f90 +++ b/src/lib/lib9290/getrsl_I.f90 @@ -1,17 +1,17 @@ - MODULE getrsl_I + MODULE getrsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:14 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:14 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE getrsl (INDX, NSUBS) - INTEGER, DIMENSION(*), INTENT(INOUT) :: INDX - INTEGER, INTENT(OUT) :: NSUBS + SUBROUTINE getrsl (INDX, NSUBS) + INTEGER, DIMENSION(*), INTENT(INOUT) :: INDX + INTEGER, INTENT(OUT) :: NSUBS !VAST.../ORB2/ NW(IN) !VAST.../ORB4/ NP(IN) !VAST.../ORB10/ NH(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: LDIGIT, CONVRT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/getyn.f90 b/src/lib/lib9290/getyn.f90 index 4534ab6fc..e003b0bf7 100644 --- a/src/lib/lib9290/getyn.f90 +++ b/src/lib/lib9290/getyn.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - LOGICAL FUNCTION GETYN () + LOGICAL FUNCTION GETYN () ! * ! This subprogram reads a response on the default input unit; the * ! response must be either 'y' or 'n'. GETYN is .TRUE. if 'y' is en- * @@ -10,11 +10,11 @@ LOGICAL FUNCTION GETYN () ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:16 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:16 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE IOUNIT_C, ONLY: ISTDI, ISTDE IMPLICIT NONE @@ -23,16 +23,16 @@ LOGICAL FUNCTION GETYN () !----------------------------------------------- CHARACTER (LEN = 1) :: RSPNS !----------------------------------------------- - 1 CONTINUE - READ (ISTDI, '(A)') RSPNS - IF (RSPNS == 'y' .OR. RSPNS == 'Y') THEN - GETYN = .TRUE. - ELSE IF (RSPNS == 'n' .OR. RSPNS == 'N') THEN - GETYN = .FALSE. - ELSE - WRITE (ISTDE, *) 'Expecting or ...' - GO TO 1 - ENDIF + 1 CONTINUE + READ (ISTDI, '(A)') RSPNS + IF (RSPNS == 'y' .OR. RSPNS == 'Y') THEN + GETYN = .TRUE. + ELSE IF (RSPNS == 'n' .OR. RSPNS == 'N') THEN + GETYN = .FALSE. + ELSE + WRITE (ISTDE, *) 'Expecting or ...' + GO TO 1 + ENDIF ! - RETURN - END FUNCTION GETYN + RETURN + END FUNCTION GETYN diff --git a/src/lib/lib9290/getyn_I.f90 b/src/lib/lib9290/getyn_I.f90 index ef50d6940..4110cbfb8 100644 --- a/src/lib/lib9290/getyn_I.f90 +++ b/src/lib/lib9290/getyn_I.f90 @@ -1,10 +1,10 @@ - MODULE getyn_I + MODULE getyn_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:16 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:16 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL FUNCTION getyn ( ) + LOGICAL FUNCTION getyn ( ) !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ichkq1.f90 b/src/lib/lib9290/ichkq1.f90 index d2660e38d..943ed09eb 100644 --- a/src/lib/lib9290/ichkq1.f90 +++ b/src/lib/lib9290/ichkq1.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ICHKQ1 (JA, JB) + INTEGER FUNCTION ICHKQ1 (JA, JB) ! * ! This routine is to check the occupation condition for one electron * ! operator. * @@ -10,44 +10,44 @@ INTEGER FUNCTION ICHKQ1 (JA, JB) ! Yu Zou Last revision: 8/16/00 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:20 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:20 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE ORB_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB + INTEGER :: JA + INTEGER :: JB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, I, I_IQA, I_IQB + INTEGER :: K, I, I_IQA, I_IQB !----------------------------------------------- ! ! - ICHKQ1 = 0 - K = 0 - DO I = 1, NW - I_IQA = IQ(I,JA) - I_IQB = IQ(I,JB) - IF (I_IQA == I_IQB) CYCLE - K = K + 1 - IF (K > 2) RETURN - IF (IABS(I_IQA - I_IQB) <= 1) CYCLE - RETURN - END DO - IF (K==2 .OR. K==0) ICHKQ1 = 1 - RETURN - END FUNCTION ICHKQ1 + ICHKQ1 = 0 + K = 0 + DO I = 1, NW + I_IQA = IQ(I,JA) + I_IQB = IQ(I,JB) + IF (I_IQA == I_IQB) CYCLE + K = K + 1 + IF (K > 2) RETURN + IF (IABS(I_IQA - I_IQB) <= 1) CYCLE + RETURN + END DO + IF (K==2 .OR. K==0) ICHKQ1 = 1 + RETURN + END FUNCTION ICHKQ1 diff --git a/src/lib/lib9290/ichkq1_I.f90 b/src/lib/lib9290/ichkq1_I.f90 index 29a65e133..a22c86e77 100644 --- a/src/lib/lib9290/ichkq1_I.f90 +++ b/src/lib/lib9290/ichkq1_I.f90 @@ -1,13 +1,13 @@ - MODULE ichkq1_I + MODULE ichkq1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:20 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:20 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ichkq1 (JA, JB) - INTEGER :: JA - INTEGER :: JB + INTEGER FUNCTION ichkq1 (JA, JB) + INTEGER :: JA + INTEGER :: JB !VAST.../ORB2/ NW(IN) !VAST...Calls: IQ - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ichkq2.f90 b/src/lib/lib9290/ichkq2.f90 index 8292a40b7..ab9cf8a0a 100644 --- a/src/lib/lib9290/ichkq2.f90 +++ b/src/lib/lib9290/ichkq2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ICHKQ2 (JA, JB) + INTEGER FUNCTION ICHKQ2 (JA, JB) ! * ! This routine is to check the occupation condition for two electron * ! operator. * @@ -10,43 +10,43 @@ INTEGER FUNCTION ICHKQ2 (JA, JB) ! Yu Zou Last revision: 8/21/00 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:21 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:21 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE ORB_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB + INTEGER :: JA + INTEGER :: JB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, I, I_IQA, I_IQB + INTEGER :: K, I, I_IQA, I_IQB !----------------------------------------------- ! ! - ICHKQ2 = 0 - K = 0 - DO I = 1, NW - I_IQA = IQ(I,JA) - I_IQB = IQ(I,JB) - IF (I_IQA == I_IQB) CYCLE - K = K + 1 - IF (K > 4) RETURN - IF (IABS(I_IQA - I_IQB) <= 2) CYCLE - RETURN - END DO - ICHKQ2 = 1 - RETURN - END FUNCTION ICHKQ2 + ICHKQ2 = 0 + K = 0 + DO I = 1, NW + I_IQA = IQ(I,JA) + I_IQB = IQ(I,JB) + IF (I_IQA == I_IQB) CYCLE + K = K + 1 + IF (K > 4) RETURN + IF (IABS(I_IQA - I_IQB) <= 2) CYCLE + RETURN + END DO + ICHKQ2 = 1 + RETURN + END FUNCTION ICHKQ2 diff --git a/src/lib/lib9290/ichkq2_I.f90 b/src/lib/lib9290/ichkq2_I.f90 index bdd6f4a62..2826be1d2 100644 --- a/src/lib/lib9290/ichkq2_I.f90 +++ b/src/lib/lib9290/ichkq2_I.f90 @@ -1,13 +1,13 @@ - MODULE ichkq2_I + MODULE ichkq2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:21 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:21 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ichkq2 (JA, JB) - INTEGER :: JA - INTEGER :: JB + INTEGER FUNCTION ichkq2 (JA, JB) + INTEGER :: JA + INTEGER :: JB !VAST.../ORB2/ NW(IN) !VAST...Calls: IQ - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ichop.f90 b/src/lib/lib9290/ichop.f90 index 603104b11..65940b0fe 100644 --- a/src/lib/lib9290/ichop.f90 +++ b/src/lib/lib9290/ichop.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ICHOP (ISUBSH, ICSF) + INTEGER FUNCTION ICHOP (ISUBSH, ICSF) ! * ! ICHOP is -1 if subshell ISUBSH is empty in CSF ICSF, +1 if the * ! subshell is full, and 0 if it is open. * @@ -10,28 +10,28 @@ INTEGER FUNCTION ICHOP (ISUBSH, ICSF) ! Written by Farid A. Parpia Last revision: 30 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:25 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW - USE ORB_C, ONLY: NKL, NKJ + USE ORB_C, ONLY: NKL, NKJ !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I + USE iq_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ISUBSH - INTEGER :: ICSF + INTEGER :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IOCC, IFULL + INTEGER :: IOCC, IFULL !----------------------------------------------- ! ! @@ -39,15 +39,15 @@ INTEGER FUNCTION ICHOP (ISUBSH, ICSF) ! appropriate range, testing seems redundant ! IF ((ISUBSH .GE. 1) .AND. (ISUBSH .LE. NW)) THEN ! IF ((ICSF .GE. 1) .AND. (ICSF .LE. NCF)) THEN - IOCC = IQ(ISUBSH,ICSF) - IFULL = NKJ(ISUBSH) + 1 - IF (IOCC == 0) THEN - ICHOP = -1 - ELSE IF (IOCC == IFULL) THEN - ICHOP = 1 - ELSE - ICHOP = 0 - ENDIF + IOCC = IQ(ISUBSH,ICSF) + IFULL = NKJ(ISUBSH) + 1 + IF (IOCC == 0) THEN + ICHOP = -1 + ELSE IF (IOCC == IFULL) THEN + ICHOP = 1 + ELSE + ICHOP = 0 + ENDIF ! ELSE ! PRINT *, 'ICHOP: Argument ICSF is out of range.' ! STOP @@ -57,5 +57,5 @@ INTEGER FUNCTION ICHOP (ISUBSH, ICSF) ! STOP ! ENDIF ! - RETURN - END FUNCTION ICHOP + RETURN + END FUNCTION ICHOP diff --git a/src/lib/lib9290/ichop_I.f90 b/src/lib/lib9290/ichop_I.f90 index 2a73d578d..f7e4cb1c4 100644 --- a/src/lib/lib9290/ichop_I.f90 +++ b/src/lib/lib9290/ichop_I.f90 @@ -1,11 +1,11 @@ - MODULE ichop_I + MODULE ichop_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:25 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ichop (ISUBSH, ICSF) - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION ichop (ISUBSH, ICSF) + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/icopy.f90 b/src/lib/lib9290/icopy.f90 index 2c8eb2bc0..c341b3d52 100644 --- a/src/lib/lib9290/icopy.f90 +++ b/src/lib/lib9290/icopy.f90 @@ -1,31 +1,31 @@ - subroutine icopy(n, ix, incx, iy, incy) + subroutine icopy(n, ix, incx, iy, incy) ! ! copies a vector, x, to a vector, y. ! uses unrolled loops for increments equal to one. ! jack dongarra, linpack, 3/11/78. ! !************************************************************************* -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:29 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:29 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer, intent(in) :: n - integer :: incx - integer :: incy + integer, intent(in) :: n + integer :: incx + integer :: incy INTEGER, DIMENSION(*), INTENT(IN) :: IX INTEGER, DIMENSION(*), INTENT(OUT) :: IY !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, m, mp1 + integer :: i, m, mp1 !----------------------------------------------- ! ! - if (n <= 0) return + if (n <= 0) return ! ! code for unequal increments or equal increments ! not equal to 1 @@ -36,12 +36,12 @@ subroutine icopy(n, ix, incx, iy, incy) ! ! clean-up loop ! - m = mod(n,7) - if (m /= 0) then - iy(:m) = ix(:m) - if (n < 7) return - endif - mp1 = m + 1 - iy(mp1:((n-mp1+7)/7)*7-1+mp1) = ix(mp1:((n-mp1+7)/7)*7-1+mp1) - return - end subroutine icopy + m = mod(n,7) + if (m /= 0) then + iy(:m) = ix(:m) + if (n < 7) return + endif + mp1 = m + 1 + iy(mp1:((n-mp1+7)/7)*7-1+mp1) = ix(mp1:((n-mp1+7)/7)*7-1+mp1) + return + end subroutine icopy diff --git a/src/lib/lib9290/icopy_I.f90 b/src/lib/lib9290/icopy_I.f90 index d4fd5bbcb..a7cb956f9 100644 --- a/src/lib/lib9290/icopy_I.f90 +++ b/src/lib/lib9290/icopy_I.f90 @@ -1,16 +1,16 @@ - MODULE icopy_I + MODULE icopy_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:29 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:29 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE icopy (N, IX, INCX, IY, INCY) - INTEGER, INTENT(IN) :: N - INTEGER, DIMENSION(*), INTENT(IN) :: IX - INTEGER :: INCX + SUBROUTINE icopy (N, IX, INCX, IY, INCY) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(*), INTENT(IN) :: IX + INTEGER :: INCX !VAST...Dummy argument INCX is not referenced in this routine. - INTEGER, DIMENSION(*), INTENT(OUT) :: IY - INTEGER :: INCY + INTEGER, DIMENSION(*), INTENT(OUT) :: IY + INTEGER :: INCY !VAST...Dummy argument INCY is not referenced in this routine. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/iniest2.f90 b/src/lib/lib9290/iniest2.f90 index 93696c0d3..cea690229 100644 --- a/src/lib/lib9290/iniest2.f90 +++ b/src/lib/lib9290/iniest2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE INIEST2(NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) + SUBROUTINE INIEST2(NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) ! ! Serial version of iniestmpi. ! Structure of the input sparse matrix hmx: @@ -12,21 +12,21 @@ SUBROUTINE INIEST2(NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) ! Xinghong He 98-10-28 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NMAX - INTEGER, INTENT(IN) :: NCF - INTEGER :: NIV + INTEGER, INTENT(IN) :: NMAX + INTEGER, INTENT(IN) :: NCF + INTEGER :: NIV INTEGER, DIMENSION(0:*), INTENT(IN) :: JCOL INTEGER, DIMENSION(*), INTENT(IN) :: IROW REAL(DOUBLE), DIMENSION(*) :: BASIS @@ -34,53 +34,53 @@ SUBROUTINE INIEST2(NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NS, JOFFSPAR, J, JOFFNORM, IR, NFOUND, INFO, IERR + INTEGER :: NS, JOFFSPAR, J, JOFFNORM, IR, NFOUND, INFO, IERR - integer, dimension(:), pointer :: iwork,ifail - real(double), dimension(:), pointer :: ap, eigval,vec, work + integer, dimension(:), pointer :: iwork,ifail + real(double), dimension(:), pointer :: ap, eigval,vec, work !----------------------------------------------- - NS = MIN(NMAX,NCF) + NS = MIN(NMAX,NCF) CALL ALLOC (AP, (NS*(NS + 1))/2, 'AP', 'INIEST2') - CALL DINIT ((NS*(NS + 1))/2, 0.D0, AP, 1) - + CALL DINIT ((NS*(NS + 1))/2, 0.D0, AP, 1) + ! Expand the sparse form to normal form for upper-right sub-matrix - - JOFFSPAR = 0 ! offset for sparse form - DO J = 1, NS - JOFFNORM = (J*(J - 1))/2 ! offset for normal form - DO IR = JOFFSPAR + 1, JCOL(J) - AP(IROW(IR)+JOFFNORM) = HMX(IR) - END DO - JOFFSPAR = JCOL(J) - END DO - + + JOFFSPAR = 0 ! offset for sparse form + DO J = 1, NS + JOFFNORM = (J*(J - 1))/2 ! offset for normal form + DO IR = JOFFSPAR + 1, JCOL(J) + AP(IROW(IR)+JOFFNORM) = HMX(IR) + END DO + JOFFSPAR = JCOL(J) + END DO + ! Merge ap from all nodes and then send to all nodes - + CALL ALLOC(eigval, ns, 'EIGVAL', 'INIEST2') CALL ALLOC (vec, ns*niv, 'VEC', 'INIEST2') CALL ALLOC (work, 8*ns, 'WORK', 'INIEST2') CALL ALLOC (iwork, 8*ns, 'IWORK', 'INIEST2') CALL ALLOC (ifail, ns, 'IFAIL', 'INIEST2') - + CALL DSPEVX ('Vectors also', 'In a range', 'Upper triangular', NS, AP, & -1., -1., 1, NIV, 0.D0, NFOUND, EIGVAL, VEC, NS, WORK, IWORK, IFAIL, & - INFO) - IERR = -ABS(INFO) + INFO) + IERR = -ABS(INFO) ! Build the Basis. - - CALL DINIT (NCF*NIV, 0.D0, BASIS, 1) - + + CALL DINIT (NCF*NIV, 0.D0, BASIS, 1) + ! scatter the vectors - - DO J = 1, NIV - CALL DCOPY (NS, VEC(NS*(J-1)+1), 1, BASIS(NCF*(J-1)+1), 1) - END DO - - CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*NCF+1), 1) - + + DO J = 1, NIV + CALL DCOPY (NS, VEC(NS*(J-1)+1), 1, BASIS(NCF*(J-1)+1), 1) + END DO + + CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*NCF+1), 1) + !deallocate(ap) !deallocate(eigval) !deallocate(vec) @@ -93,6 +93,6 @@ SUBROUTINE INIEST2(NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) CALL DALLOC (work, 'WORK', 'INIEST2') CALL DALLOC (iwork, 'IWORK', 'INIEST2') CALL DALLOC (ifail, 'IFAIL', 'INIEST2') - - RETURN - END SUBROUTINE INIEST2 + + RETURN + END SUBROUTINE INIEST2 diff --git a/src/lib/lib9290/iniest2_I.f90 b/src/lib/lib9290/iniest2_I.f90 index e8d7e60de..c68c7d612 100644 --- a/src/lib/lib9290/iniest2_I.f90 +++ b/src/lib/lib9290/iniest2_I.f90 @@ -1,18 +1,18 @@ - MODULE iniest2_I + MODULE iniest2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE iniest2 (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: NMAX - INTEGER, INTENT(IN) :: NCF - INTEGER, INTENT(IN) :: NIV - REAL(DOUBLE), DIMENSION(*) :: BASIS - REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: HMX - INTEGER, DIMENSION(0:*), INTENT(IN) :: JCOL - INTEGER, DIMENSION(*), INTENT(IN) :: IROW + SUBROUTINE iniest2 (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: NMAX + INTEGER, INTENT(IN) :: NCF + INTEGER, INTENT(IN) :: NIV + REAL(DOUBLE), DIMENSION(*) :: BASIS + REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: HMX + INTEGER, DIMENSION(0:*), INTENT(IN) :: JCOL + INTEGER, DIMENSION(*), INTENT(IN) :: IROW !VAST...Calls: ALLOC, DINIT, DSPEVX, DCOPY, DALLOC - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/interp.f90 b/src/lib/lib9290/interp.f90 index 2fca3183b..659765e48 100644 --- a/src/lib/lib9290/interp.f90 +++ b/src/lib/lib9290/interp.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTERP(XARR, YARR, NARR, XVAL, YVAL, ACCY) + SUBROUTINE INTERP(XARR, YARR, NARR, XVAL, YVAL, ACCY) ! * ! This routine returns YVAL given a value XVAL by interpolating * ! using a pair of arrays XARR(1:NARR), YARR(1:NARR), that tabulate * @@ -13,37 +13,37 @@ SUBROUTINE INTERP(XARR, YARR, NARR, XVAL, YVAL, ACCY) ! Written by Farid A Parpia, at Oxford Last update: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:32 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:32 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NARR - REAL(DOUBLE), INTENT(IN) :: XVAL - REAL(DOUBLE), INTENT(OUT) :: YVAL - REAL(DOUBLE), INTENT(IN) :: ACCY + INTEGER, INTENT(IN) :: NARR + REAL(DOUBLE), INTENT(IN) :: XVAL + REAL(DOUBLE), INTENT(OUT) :: YVAL + REAL(DOUBLE), INTENT(IN) :: ACCY REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: XARR REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: YARR !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 11 + INTEGER, PARAMETER :: MXORD = 11 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NRSTLO, NRSTHI, K, LLO, LHI, LLR, IROW, LOCNXT, ILIROK, ILDIAG& - , ILOTHR, IBEST - REAL(DOUBLE), DIMENSION(MXORD) :: DX, X, EST - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLY - REAL(DOUBLE) :: DIFF, DIFFT, DEBEB, DEBE - LOGICAL :: SET - LOGICAL, DIMENSION(2*MXORD + 2) :: USED + , ILOTHR, IBEST + REAL(DOUBLE), DIMENSION(MXORD) :: DX, X, EST + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLY + REAL(DOUBLE) :: DIFF, DIFFT, DEBEB, DEBE + LOGICAL :: SET + LOGICAL, DIMENSION(2*MXORD + 2) :: USED !----------------------------------------------- ! ! @@ -56,121 +56,121 @@ SUBROUTINE INTERP(XARR, YARR, NARR, XVAL, YVAL, ACCY) ! ! Determine the nearest two XARR entries bounding XVAL ! - IF (XVAL < XARR(1)) THEN - NRSTLO = 1 - NRSTHI = 1 - WRITE (*, 300) - ELSE IF (XVAL > XARR(NARR)) THEN - NRSTLO = NARR - NRSTHI = NARR - WRITE (*, 300) - ELSE - K = 0 - 1 CONTINUE - K = K + 1 - IF (XARR(K) < XVAL) THEN - NRSTLO = K - GO TO 1 - ELSE - NRSTHI = K - ENDIF - ENDIF + IF (XVAL < XARR(1)) THEN + NRSTLO = 1 + NRSTHI = 1 + WRITE (*, 300) + ELSE IF (XVAL > XARR(NARR)) THEN + NRSTLO = NARR + NRSTHI = NARR + WRITE (*, 300) + ELSE + K = 0 + 1 CONTINUE + K = K + 1 + IF (XARR(K) < XVAL) THEN + NRSTLO = K + GO TO 1 + ELSE + NRSTHI = K + ENDIF + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,NARR) - LLR = LLO - 1 - USED(LLO-LLR:LHI-LLR) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,NARR) + LLR = LLO - 1 + USED(LLO-LLR:LHI-LLR) = .FALSE. ! ! Determine next-nearest XARR entry ! - DO IROW = 1, MXORD - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,NARR) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K-LLR)) CYCLE - IF (.NOT.SET) THEN - DIFF = XARR(K) - XVAL - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = XARR(K) - XVAL - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT-LLR) = .TRUE. - X(IROW) = XARR(LOCNXT) - DX(IROW) = DIFF + DO IROW = 1, MXORD + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,NARR) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K-LLR)) CYCLE + IF (.NOT.SET) THEN + DIFF = XARR(K) - XVAL + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = XARR(K) - XVAL + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT-LLR) = .TRUE. + X(IROW) = XARR(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLY(ILIROK) = YARR(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLY(ILIROK) = YARR(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) POLY(ILIROK) = (POLY(ILDIAG)*DX(IROW)-POLY(ILOTHR)*DX(K-1))/(X(& - IROW)-X(K-1)) - ENDIF - END DO + IROW)-X(K-1)) + ENDIF + END DO ! ! Pick off the diagonal element ! - ILDIAG = ILOC(IROW,IROW) - EST(IROW) = POLY(ILDIAG) + ILDIAG = ILOC(IROW,IROW) + EST(IROW) = POLY(ILDIAG) ! - END DO + END DO ! ! Now the estimate vector is filled in, so obtain the ! best estimate ! - DEBEB = ABS((EST(2)-EST(1))/EST(2)) - - IBEST = 2 - DO IROW = 3, MXORD - DEBE = ABS((EST(IROW)-EST(IROW-1))/EST(IROW)) - + DEBEB = ABS((EST(2)-EST(1))/EST(2)) + + IBEST = 2 + DO IROW = 3, MXORD + DEBE = ABS((EST(IROW)-EST(IROW-1))/EST(IROW)) + !ps 13/12/2017 !ps If NARR is small, the EST array sometimes contains the NaN values. !ps In a consequence, DEBE becomes NaN, and in that case the condition -!ps in the CYCLE statement (NaN >= number) is then evaluated to "false". -!ps So, the CYCLE is not performed, what is incorrect. +!ps in the CYCLE statement (NaN >= number) is then evaluated to "false". +!ps So, the CYCLE is not performed, what is incorrect. !ps To avoid this, the CYCLE was replaced with the IF / THEN / END IF !ps (the condition was reversed). - !ps IF (DEBE >= DEBEB) CYCLE - !ps DEBEB = DEBE - !ps IBEST = IROW + !ps IF (DEBE >= DEBEB) CYCLE + !ps DEBEB = DEBE + !ps IBEST = IROW IF (DEBE < DEBEB) THEN DEBEB = DEBE IBEST = IROW - END IF - - END DO - YVAL = EST(IBEST) + END IF + + END DO + YVAL = EST(IBEST) ! - IF (DEBEB > ACCY) WRITE (*, 301) DEBEB, ACCY + IF (DEBEB > ACCY) WRITE (*, 301) DEBEB, ACCY ! - RETURN + RETURN ! - 300 FORMAT('INTERP: Extrapolating, not interpolating.') + 300 FORMAT('INTERP: Extrapolating, not interpolating.') 301 FORMAT('INTERP: Accuracy of interpolation (',1P,1D10.3,') is',& - ' below input criterion (',1D10.3,').') - RETURN - CONTAINS + ' below input criterion (',1D10.3,').') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTERP + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTERP diff --git a/src/lib/lib9290/interp_I.f90 b/src/lib/lib9290/interp_I.f90 index 4ab3ac22d..8d8a5422b 100644 --- a/src/lib/lib9290/interp_I.f90 +++ b/src/lib/lib9290/interp_I.f90 @@ -1,19 +1,19 @@ - MODULE interp_I + MODULE interp_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:32 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:32 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE interp (XARR, YARR, NARR, XVAL, YVAL, ACCY) - USE vast_kind_param,ONLY: DOUBLE - INTEGER MXORD - PARAMETER (MXORD = 11) - REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: XARR - REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: YARR - INTEGER, INTENT(IN) :: NARR - REAL(DOUBLE), INTENT(IN) :: XVAL - REAL(DOUBLE), INTENT(OUT) :: YVAL - REAL(DOUBLE), INTENT(IN) :: ACCY + SUBROUTINE interp (XARR, YARR, NARR, XVAL, YVAL, ACCY) + USE vast_kind_param,ONLY: DOUBLE + INTEGER MXORD + PARAMETER (MXORD = 11) + REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: XARR + REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: YARR + INTEGER, INTENT(IN) :: NARR + REAL(DOUBLE), INTENT(IN) :: XVAL + REAL(DOUBLE), INTENT(OUT) :: YVAL + REAL(DOUBLE), INTENT(IN) :: ACCY !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/intrpq.f90 b/src/lib/lib9290/intrpq.f90 index 114a6f88c..697fae514 100644 --- a/src/lib/lib9290/intrpq.f90 +++ b/src/lib/lib9290/intrpq.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE INTRPQ(PA, QA, MA, RA, J, DNORM) + SUBROUTINE INTRPQ(PA, QA, MA, RA, J, DNORM) ! * ! This subprogram interpolates the arrays PA(1:MA), QA(1:MA), * ! tabulated on grid RA(1:MA) into the COMMON arrays PF(1:MF(J),J), * @@ -13,46 +13,46 @@ SUBROUTINE INTRPQ(PA, QA, MA, RA, J, DNORM) ! Written by Farid A Parpia, at Oxford Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:37:49 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:37:49 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE DEBUG_C - USE DEF_C, ONLY: ACCY - USE GRID_C - USE WAVE_C + USE DEBUG_C + USE DEF_C, ONLY: ACCY + USE GRID_C + USE WAVE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I + USE rint_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MA - INTEGER :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM + INTEGER, INTENT(IN) :: MA + INTEGER :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA, QA, RA !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: MXORD = 13 + INTEGER, PARAMETER :: MXORD = 13 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I, MFJ, NRSTLO, KOUNT, IROW, K, NRSTHI, LLO, LHI, LOCNXT, & - ILIROK, ILDIAG, ILOTHR, MFJP1 - REAL(DOUBLE) :: RAMA - REAL(DOUBLE), DIMENSION(MXORD) :: X, DX - REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ + ILIROK, ILDIAG, ILOTHR, MFJP1 + REAL(DOUBLE) :: RAMA + REAL(DOUBLE), DIMENSION(MXORD) :: X, DX + REAL(DOUBLE), DIMENSION((MXORD*(MXORD + 1))/2) :: POLYP, POLYQ REAL(DOUBLE) :: RN, XBAR, PESTL, QESTL, DIFF, DIFFT, DXKMN1, DXIROW, & - FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC - LOGICAL :: SET - LOGICAL, DIMENSION(NNNP) :: USED + FACTOR, PESTT, QESTT, DPBP, DQBQ, DNFAC + LOGICAL :: SET + LOGICAL, DIMENSION(NNNP) :: USED !----------------------------------------------- ! ! @@ -62,178 +62,178 @@ SUBROUTINE INTRPQ(PA, QA, MA, RA, J, DNORM) ! ! Initialization ! - RAMA = RA(MA) - RN = R(N) + RAMA = RA(MA) + RN = R(N) ! ! This is always true in GRASP ! - PF(1,J) = 0.0D00 - QF(1,J) = 0.0D00 + PF(1,J) = 0.0D00 + QF(1,J) = 0.0D00 ! ! Checks ! - IF (RAMA > RN) THEN - WRITE (*, 300) RN, RAMA + IF (RAMA > RN) THEN + WRITE (*, 300) RN, RAMA PRINT*, "N =",N,"MA =",MA - STOP - ENDIF + STOP + ENDIF ! ! Determine end of grid ! - I = N - 1 CONTINUE - I = I - 1 - IF (R(I) <= RAMA) THEN - MFJ = I - ELSE - GO TO 1 - ENDIF - MF(J) = MFJ + I = N + 1 CONTINUE + I = I - 1 + IF (R(I) <= RAMA) THEN + MFJ = I + ELSE + GO TO 1 + ENDIF + MF(J) = MFJ ! ! Overall initialization for interpolation ! - NRSTLO = 0 - KOUNT = 0 + NRSTLO = 0 + KOUNT = 0 ! ! Perform interpolation ! - DO I = 2, MFJ + DO I = 2, MFJ ! ! Initialization for interpolation ! - XBAR = R(I) - IROW = 0 - PESTL = 0.0D00 - QESTL = 0.0D00 + XBAR = R(I) + IROW = 0 + PESTL = 0.0D00 + QESTL = 0.0D00 ! ! Determine the nearest two grid points bounding the present ! grid point ! - 2 CONTINUE - K = NRSTLO + 1 - IF (RA(K) < XBAR) THEN - NRSTLO = K - GO TO 2 - ELSE - NRSTHI = K - ENDIF + 2 CONTINUE + K = NRSTLO + 1 + IF (RA(K) < XBAR) THEN + NRSTLO = K + GO TO 2 + ELSE + NRSTHI = K + ENDIF ! ! Clear relevant piece of use-indicator array ! - LLO = MAX(NRSTLO - MXORD,1) - LHI = MIN(NRSTHI + MXORD,MA) - USED(LLO:LHI) = .FALSE. + LLO = MAX(NRSTLO - MXORD,1) + LHI = MIN(NRSTHI + MXORD,MA) + USED(LLO:LHI) = .FALSE. ! ! Determine next-nearest grid point ! - 4 CONTINUE - IROW = IROW + 1 - LLO = MAX(NRSTLO - IROW + 1,1) - LHI = MIN(NRSTHI + IROW - 1,MA) - SET = .FALSE. - DO K = LLO, LHI - IF (USED(K)) CYCLE - IF (.NOT.SET) THEN - DIFF = RA(K) - XBAR - LOCNXT = K - SET = .TRUE. - ELSE - DIFFT = RA(K) - XBAR - IF (ABS(DIFFT) < ABS(DIFF)) THEN - DIFF = DIFFT - LOCNXT = K - ENDIF - ENDIF - END DO - USED(LOCNXT) = .TRUE. - X(IROW) = RA(LOCNXT) - DX(IROW) = DIFF + 4 CONTINUE + IROW = IROW + 1 + LLO = MAX(NRSTLO - IROW + 1,1) + LHI = MIN(NRSTHI + IROW - 1,MA) + SET = .FALSE. + DO K = LLO, LHI + IF (USED(K)) CYCLE + IF (.NOT.SET) THEN + DIFF = RA(K) - XBAR + LOCNXT = K + SET = .TRUE. + ELSE + DIFFT = RA(K) - XBAR + IF (ABS(DIFFT) < ABS(DIFF)) THEN + DIFF = DIFFT + LOCNXT = K + ENDIF + ENDIF + END DO + USED(LOCNXT) = .TRUE. + X(IROW) = RA(LOCNXT) + DX(IROW) = DIFF ! ! Fill table for this row ! - DO K = 1, IROW - ILIROK = ILOC(IROW,K) - IF (K == 1) THEN - POLYP(ILIROK) = PA(LOCNXT) - POLYQ(ILIROK) = QA(LOCNXT) - ELSE - ILDIAG = ILOC(K - 1,K - 1) - ILOTHR = ILOC(IROW,K - 1) - DXKMN1 = DX(K-1) - DXIROW = DX(IROW) - FACTOR = 1.0D00/(X(IROW)-X(K-1)) + DO K = 1, IROW + ILIROK = ILOC(IROW,K) + IF (K == 1) THEN + POLYP(ILIROK) = PA(LOCNXT) + POLYQ(ILIROK) = QA(LOCNXT) + ELSE + ILDIAG = ILOC(K - 1,K - 1) + ILOTHR = ILOC(IROW,K - 1) + DXKMN1 = DX(K-1) + DXIROW = DX(IROW) + FACTOR = 1.0D00/(X(IROW)-X(K-1)) POLYP(ILIROK) = (POLYP(ILDIAG)*DXIROW-POLYP(ILOTHR)*DXKMN1)*& - FACTOR + FACTOR POLYQ(ILIROK) = (POLYQ(ILDIAG)*DXIROW-POLYQ(ILOTHR)*DXKMN1)*& - FACTOR - ENDIF - END DO + FACTOR + ENDIF + END DO ! ! Check for convergence ! - ILDIAG = ILOC(IROW,IROW) - PESTT = POLYP(ILDIAG) - QESTT = POLYQ(ILDIAG) - IF (PESTT==0.0D00 .OR. QESTT==0.0D00) THEN - IF (IROW < MXORD) THEN - GO TO 4 - ELSE - PF(I,J) = PESTT - QF(I,J) = QESTT - ENDIF - ELSE - DPBP = ABS((PESTT - PESTL)/PESTT) - DQBQ = ABS((QESTT - QESTL)/QESTT) - IF (DQBQ0) WRITE (99, 301) ACCY, KOUNT, MFJ + IF (LDBPR(3) .AND. KOUNT>0) WRITE (99, 301) ACCY, KOUNT, MFJ ! ! Normalization ! - DNORM = RINT(J,J,0) - DNFAC = 1.0D00/SQRT(DNORM) - PF(:MFJ,J) = PF(:MFJ,J)*DNFAC - QF(:MFJ,J) = QF(:MFJ,J)*DNFAC + DNORM = RINT(J,J,0) + DNFAC = 1.0D00/SQRT(DNORM) + PF(:MFJ,J) = PF(:MFJ,J)*DNFAC + QF(:MFJ,J) = QF(:MFJ,J)*DNFAC ! - RETURN + RETURN ! 300 FORMAT(/,'INTRPQ: Grid of insufficient extent:'/,& ' Present grid has R(N) = ',1P,1D19.12,' Bohr radii'/,& - ' Require R(N) = ',1D19.12,' Bohr radii') + ' Require R(N) = ',1D19.12,' Bohr radii') 301 FORMAT(/,'INTRPQ: Interpolation procedure not converged to',1P,1D19.12,& - ' for ',1I3,' of ',1I3,' tabulation points') - RETURN - CONTAINS + ' for ',1I3,' of ',1I3,' tabulation points') + RETURN + CONTAINS - INTEGER FUNCTION ILOC (IND1, IND2) - INTEGER, INTENT(IN) :: IND1 - INTEGER, INTENT(IN) :: IND2 - ILOC = (IND1*(IND1 - 1))/2 + IND2 - RETURN - END FUNCTION ILOC -! - END SUBROUTINE INTRPQ + INTEGER FUNCTION ILOC (IND1, IND2) + INTEGER, INTENT(IN) :: IND1 + INTEGER, INTENT(IN) :: IND2 + ILOC = (IND1*(IND1 - 1))/2 + IND2 + RETURN + END FUNCTION ILOC +! + END SUBROUTINE INTRPQ diff --git a/src/lib/lib9290/intrpq_I.f90 b/src/lib/lib9290/intrpq_I.f90 index 1461f8fd7..674e4e7eb 100644 --- a/src/lib/lib9290/intrpq_I.f90 +++ b/src/lib/lib9290/intrpq_I.f90 @@ -1,16 +1,16 @@ - MODULE intrpq_I + MODULE intrpq_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:33:45 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:33:45 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE intrpq (PA, QA, MA, RA, J, DNORM) - USE vast_kind_param,ONLY: DOUBLE - INTEGER MXORD - PARAMETER (MXORD = 13) + SUBROUTINE intrpq (PA, QA, MA, RA, J, DNORM) + USE vast_kind_param,ONLY: DOUBLE + INTEGER MXORD + PARAMETER (MXORD = 13) REAL(DOUBLE), DIMENSION(*), INTENT(IN) :: PA, QA, RA - INTEGER, INTENT(IN) :: MA - INTEGER, INTENT(IN) :: J - REAL(DOUBLE), INTENT(OUT) :: DNORM - END SUBROUTINE - END INTERFACE - END MODULE + INTEGER, INTENT(IN) :: MA + INTEGER, INTENT(IN) :: J + REAL(DOUBLE), INTENT(OUT) :: DNORM + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/iq.f90 b/src/lib/lib9290/iq.f90 index b4cd421f0..1ef4ffe13 100644 --- a/src/lib/lib9290/iq.f90 +++ b/src/lib/lib9290/iq.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION IQ (ISUBSH, ICSF) + INTEGER FUNCTION IQ (ISUBSH, ICSF) ! * ! IQ is the occupation of subshell ISUBSH in CSF ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION IQ (ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE ORB_C, ONLY: IQA, NCF @@ -21,11 +21,11 @@ INTEGER FUNCTION IQ (ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! - IQ = IQA(isubsh,icsf) + IQ = IQA(isubsh,icsf) ! - RETURN - END FUNCTION IQ + RETURN + END FUNCTION IQ diff --git a/src/lib/lib9290/iq_I.f90 b/src/lib/lib9290/iq_I.f90 index 4a00343cd..73e9b9073 100644 --- a/src/lib/lib9290/iq_I.f90 +++ b/src/lib/lib9290/iq_I.f90 @@ -1,12 +1,12 @@ - MODULE iq_I + MODULE iq_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION iq (ISUBSH, ICSF) - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER FUNCTION iq (ISUBSH, ICSF) + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !VAST...Calls: IQA - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ispar.f90 b/src/lib/lib9290/ispar.f90 index 6abe18e96..6a536a7ff 100644 --- a/src/lib/lib9290/ispar.f90 +++ b/src/lib/lib9290/ispar.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ISPAR (ICSF) + INTEGER FUNCTION ISPAR (ICSF) ! * ! ISPAR is the value of P for CSF number ICSF. * ! * @@ -8,34 +8,34 @@ INTEGER FUNCTION ISPAR (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA - USE IOUNIT_C, ONLY: ISTDE + USE IOUNIT_C, ONLY: ISTDE USE ORB_C, ONLY: NCF IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- ! - IF (ICSF>=1 .AND. ICSF<=NCF) THEN + IF (ICSF>=1 .AND. ICSF<=NCF) THEN ispar = jcupa(NNNW,icsf) - IF (ISPAR > 127) ISPAR = ISPAR - 256 - ISPAR = SIGN(1,ISPAR) - ELSE - WRITE (ISTDE, *) 'ISPAR: Argument ICSF is out of range.' - WRITE (ISTDE, *) 'ICSF =',ICSF,' NCF =',NCF - STOP - ENDIF + IF (ISPAR > 127) ISPAR = ISPAR - 256 + ISPAR = SIGN(1,ISPAR) + ELSE + WRITE (ISTDE, *) 'ISPAR: Argument ICSF is out of range.' + WRITE (ISTDE, *) 'ICSF =',ICSF,' NCF =',NCF + STOP + ENDIF ! - RETURN - END FUNCTION ISPAR + RETURN + END FUNCTION ISPAR diff --git a/src/lib/lib9290/ispar_I.f90 b/src/lib/lib9290/ispar_I.f90 index 545ca4a0e..288d27355 100644 --- a/src/lib/lib9290/ispar_I.f90 +++ b/src/lib/lib9290/ispar_I.f90 @@ -1,14 +1,14 @@ - MODULE ispar_I + MODULE ispar_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:41 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION ispar (ICSF) - INTEGER, INTENT(IN) :: ICSF + INTEGER FUNCTION ispar (ICSF) + INTEGER, INTENT(IN) :: ICSF !VAST.../ORB2/ NCF(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: JCUPA !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/items.f90 b/src/lib/lib9290/items.f90 index 2f4dcaa84..5ffae5c5f 100644 --- a/src/lib/lib9290/items.f90 +++ b/src/lib/lib9290/items.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - subroutine items(ncmin, ncf, record, ierr) + subroutine items(ncmin, ncf, record, ierr) ! ! Purpose: ! Parse a list of levels stored in char string record. Formats @@ -30,149 +30,149 @@ subroutine items(ncmin, ncf, record, ierr) ! Parameter ncd removed for simpler structure Jun 10 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 19:51:17 2/16/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 19:51:17 2/16/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man - USE def_C, ONLY: ICCMIN - USE iounit_C + USE def_C, ONLY: ICCMIN + USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - use convrt_I + use convrt_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: ncmin - integer, intent(in) :: ncf - integer, intent(out) :: ierr + integer :: ncmin + integer, intent(in) :: ncf + integer, intent(out) :: ierr CHARACTER (LEN = *), INTENT(IN) :: RECORD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- integer :: length_of_record, ncmin_in, ncd, ifirst, istart, i, iend, & - isize, lenth, ios, level, level1, number, j - character :: reci, form*7, cnum*3 + isize, lenth, ios, level, level1, number, j + character :: reci, form*7, cnum*3 !----------------------------------------------- ! ! - - length_of_record = len_trim(record) - - ncmin_in = ncmin - ncd = ncmin ! Current length of array iccmin() - - if (ncd == 0) then - ncd = 1 - call alloc (iccmin, ncd, 'ICCMIN', 'ITEMS') - endif + + length_of_record = len_trim(record) + + ncmin_in = ncmin + ncd = ncmin ! Current length of array iccmin() + + if (ncd == 0) then + ncd = 1 + call alloc (iccmin, ncd, 'ICCMIN', 'ITEMS') + endif ! ! parse record from left to right ! - ifirst = 0 - istart = 1 - i = 1 + ifirst = 0 + istart = 1 + i = 1 ! ! .. skip the blanks and commas(this implementation allows input to ! start with blanks ! - 2 continue - reci = record(i:i) - if (reci/=' ' .and. reci/=',') then - istart = i - else - i = i + 1 - if (i <= length_of_record) then - go to 2 - else - go to 4 - endif - endif + 2 continue + reci = record(i:i) + if (reci/=' ' .and. reci/=',') then + istart = i + else + i = i + 1 + if (i <= length_of_record) then + go to 2 + else + go to 4 + endif + endif ! ! .. search for end of string (blank, comma, or dash) ! - 3 continue - reci = record(i:i) - if (reci/=' ' .and. reci/=',' .and. reci/='-') then - i = i + 1 - if (i <= length_of_record) go to 3 - endif + 3 continue + reci = record(i:i) + if (reci/=' ' .and. reci/=',' .and. reci/='-') then + i = i + 1 + if (i <= length_of_record) go to 3 + endif ! ! ... read integer ! - iend = i - 1 - isize = iend - istart + 1 - call convrt (isize, cnum, lenth) - form = '(1i'//cnum(1:lenth)//')' - read (record(istart:iend), form, iostat=ios) level - if (ios /= 0) then - write (istde, *) 'items: unable to decode '//record(istart:iend)//';' - ierr = -1 - return - endif - - if (ifirst == 0) then + iend = i - 1 + isize = iend - istart + 1 + call convrt (isize, cnum, lenth) + form = '(1i'//cnum(1:lenth)//')' + read (record(istart:iend), form, iostat=ios) level + if (ios /= 0) then + write (istde, *) 'items: unable to decode '//record(istart:iend)//';' + ierr = -1 + return + endif + + if (ifirst == 0) then ! .. this is the either the first or an isolated level - ncmin = ncmin + 1 - if (ncmin > ncd) then - call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') - ncd = ncmin - endif - - if (level<1 .or. level>ncf) then + ncmin = ncmin + 1 + if (ncmin > ncd) then + call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') + ncd = ncmin + endif + + if (level<1 .or. level>ncf) then write (istde, *) 'items: serial numbers must be', & - ' in the range [1,', ncf, '];' - ierr = -2 - return - endif - - iccmin(ncmin) = level - i = i + 1 - if (reci == '-') ifirst = ncmin - go to 2 - else + ' in the range [1,', ncf, '];' + ierr = -2 + return + endif + + iccmin(ncmin) = level + i = i + 1 + if (reci == '-') ifirst = ncmin + go to 2 + else ! .. the previous level was the beginning of a range - level1 = iccmin(ncmin) - number = level - level1 - - if (number < 0) then - write (istde, *) level1, '-', level, ' not allowed' - ierr = -3 - return - endif - - ncmin = ncmin + number - if (ncmin > ncd) then - call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') - ncd = ncmin - endif - do j = 1, number - iccmin(ifirst+j) = level1 + j - end do - i = i + 1 - ifirst = 0 - go to 2 - endif - + level1 = iccmin(ncmin) + number = level - level1 + + if (number < 0) then + write (istde, *) level1, '-', level, ' not allowed' + ierr = -3 + return + endif + + ncmin = ncmin + number + if (ncmin > ncd) then + call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') + ncd = ncmin + endif + do j = 1, number + iccmin(ifirst+j) = level1 + j + end do + i = i + 1 + ifirst = 0 + go to 2 + endif + ! at least one level must be requested - - 4 continue - if (ncmin == ncmin_in) then - ierr = 1 - return - endif + + 4 continue + if (ncmin == ncmin_in) then + ierr = 1 + return + endif ! ! trim array to exactly the correct size ! - if (ncmin /= ncd) then - write (istde, *) 'items: ncmin .ne. ncd' - call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') - endif - - ierr = 0 - return - end subroutine items + if (ncmin /= ncd) then + write (istde, *) 'items: ncmin .ne. ncd' + call ralloc (iccmin, ncmin, 'ICCMIN', 'ITEMS') + endif + + ierr = 0 + return + end subroutine items diff --git a/src/lib/lib9290/items_I.f90 b/src/lib/lib9290/items_I.f90 index 62f1606f7..6066de971 100644 --- a/src/lib/lib9290/items_I.f90 +++ b/src/lib/lib9290/items_I.f90 @@ -1,17 +1,17 @@ - MODULE items_I + MODULE items_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 19:51:17 2/16/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 19:51:17 2/16/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE items (NCMIN, NCF, RECORD, IERR) - INTEGER, INTENT(INOUT) :: NCMIN - INTEGER, INTENT(IN) :: NCF - CHARACTER (LEN = *), INTENT(IN) :: RECORD - INTEGER, INTENT(OUT) :: IERR + SUBROUTINE items (NCMIN, NCF, RECORD, IERR) + INTEGER, INTENT(INOUT) :: NCMIN + INTEGER, INTENT(IN) :: NCF + CHARACTER (LEN = *), INTENT(IN) :: RECORD + INTEGER, INTENT(OUT) :: IERR !VAST.../DEF7/ PCCMIN(INOUT) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: ALLOC, CONVRT, RALLOC !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/itjpo.f90 b/src/lib/lib9290/itjpo.f90 index 0f0631f82..6f1df0f90 100644 --- a/src/lib/lib9290/itjpo.f90 +++ b/src/lib/lib9290/itjpo.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITJPO (ICSF) + INTEGER FUNCTION ITJPO (ICSF) ! * ! ITJPO is the value of 2J+1 for CSF number ICSF. * ! * @@ -8,11 +8,11 @@ INTEGER FUNCTION ITJPO (ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JCUPA @@ -22,16 +22,16 @@ INTEGER FUNCTION ITJPO (ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: ICSF + INTEGER :: ICSF !----------------------------------------------- - IF (ICSF>=1 .AND. ICSF<=NCF) THEN + IF (ICSF>=1 .AND. ICSF<=NCF) THEN itjpo = jcupa(NNNW,icsf) - IF (ITJPO > 127) ITJPO = 256 - ITJPO + IF (ITJPO > 127) ITJPO = 256 - ITJPO ITJPO = IABS (ITJPO) - ELSE - WRITE (ISTDE, *) 'ITJPO: Argument ICSF is out of range.' - STOP - ENDIF + ELSE + WRITE (ISTDE, *) 'ITJPO: Argument ICSF is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION ITJPO + RETURN + END FUNCTION ITJPO diff --git a/src/lib/lib9290/itjpo_I.f90 b/src/lib/lib9290/itjpo_I.f90 index ee5e03574..0150a4011 100644 --- a/src/lib/lib9290/itjpo_I.f90 +++ b/src/lib/lib9290/itjpo_I.f90 @@ -1,14 +1,14 @@ - MODULE itjpo_I + MODULE itjpo_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:45 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itjpo (ICSF) - INTEGER, INTENT(IN) :: ICSF + INTEGER FUNCTION itjpo (ICSF) + INTEGER, INTENT(IN) :: ICSF !VAST.../ORB2/ NCF(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: JCUPA !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/itrig.f90 b/src/lib/lib9290/itrig.f90 index 03f85e2ff..41072c141 100644 --- a/src/lib/lib9290/itrig.f90 +++ b/src/lib/lib9290/itrig.f90 @@ -1,37 +1,37 @@ !*********************************************************************** ! * - INTEGER FUNCTION ITRIG (I1, I2, I3) + INTEGER FUNCTION ITRIG (I1, I2, I3) ! * ! The triangular delta. Input: Values of 2*J+1; Output: 1, IF J'S * ! form a triangle; 0, otherwise. * ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:47 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:47 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: I1 - INTEGER, INTENT(IN) :: I2 - INTEGER, INTENT(IN) :: I3 + INTEGER, INTENT(IN) :: I1 + INTEGER, INTENT(IN) :: I2 + INTEGER, INTENT(IN) :: I3 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I4 + INTEGER :: I4 !----------------------------------------------- ! - I4 = I2 - I3 - IF (I1>=ABS(I4) + 1 .AND. I1<=I2+I3-1) THEN - ITRIG = 1 - ELSE - ITRIG = 0 - ENDIF + I4 = I2 - I3 + IF (I1>=ABS(I4) + 1 .AND. I1<=I2+I3-1) THEN + ITRIG = 1 + ELSE + ITRIG = 0 + ENDIF ! - RETURN - END FUNCTION ITRIG + RETURN + END FUNCTION ITRIG diff --git a/src/lib/lib9290/itrig_I.f90 b/src/lib/lib9290/itrig_I.f90 index 11d8593b9..2f65d9469 100644 --- a/src/lib/lib9290/itrig_I.f90 +++ b/src/lib/lib9290/itrig_I.f90 @@ -1,12 +1,12 @@ - MODULE itrig_I + MODULE itrig_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:47 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:47 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION itrig (I1, I2, I3) - INTEGER, INTENT(IN) :: I1 - INTEGER, INTENT(IN) :: I2 - INTEGER, INTENT(IN) :: I3 - END FUNCTION - END INTERFACE - END MODULE + INTEGER FUNCTION itrig (I1, I2, I3) + INTEGER, INTENT(IN) :: I1 + INTEGER, INTENT(IN) :: I2 + INTEGER, INTENT(IN) :: I3 + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/jcup.f90 b/src/lib/lib9290/jcup.f90 index ac6225af2..81d21891d 100644 --- a/src/lib/lib9290/jcup.f90 +++ b/src/lib/lib9290/jcup.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - INTEGER FUNCTION JCUP (LOC, ICSF) + INTEGER FUNCTION JCUP (LOC, ICSF) ! * ! JCUP is the 2J+1 value of the LOCth nontrivial intermediate ang- * ! ular momentum in CSF ICSF. * @@ -9,11 +9,11 @@ INTEGER FUNCTION JCUP (LOC, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 08:16:51 2/21/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 08:16:51 2/21/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE IOUNIT_C, ONLY: ISTDE @@ -23,21 +23,21 @@ INTEGER FUNCTION JCUP (LOC, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: LOC - INTEGER :: ICSF + INTEGER, INTENT(IN) :: LOC + INTEGER :: ICSF !----------------------------------------------- ! - IF (LOC>=1 .AND. LOC<=NNNW-1) THEN - IF (ICSF>=1 .AND. ICSF<=NCF) THEN + IF (LOC>=1 .AND. LOC<=NNNW-1) THEN + IF (ICSF>=1 .AND. ICSF<=NCF) THEN jcup = jcupa(loc,icsf) - ELSE - WRITE (ISTDE, *) 'JCUP: Argument ICSF is out of range.' - STOP - ENDIF - ELSE - WRITE (ISTDE, *) 'JCUP: Argument LOC is out of range.' - STOP - ENDIF + ELSE + WRITE (ISTDE, *) 'JCUP: Argument ICSF is out of range.' + STOP + ENDIF + ELSE + WRITE (ISTDE, *) 'JCUP: Argument LOC is out of range.' + STOP + ENDIF ! - RETURN - END FUNCTION JCUP + RETURN + END FUNCTION JCUP diff --git a/src/lib/lib9290/jcup_I.f90 b/src/lib/lib9290/jcup_I.f90 index b45383989..6825f8129 100644 --- a/src/lib/lib9290/jcup_I.f90 +++ b/src/lib/lib9290/jcup_I.f90 @@ -1,15 +1,15 @@ - MODULE jcup_I + MODULE jcup_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 08:16:51 2/21/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 08:16:51 2/21/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jcup (LOC, ICSF) - INTEGER, INTENT(IN) :: LOC - INTEGER, INTENT(IN) :: ICSF + INTEGER FUNCTION jcup (LOC, ICSF) + INTEGER, INTENT(IN) :: LOC + INTEGER, INTENT(IN) :: ICSF !VAST.../ORB2/ NCF(IN), NW(IN) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: JCUPA !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/jqs.f90 b/src/lib/lib9290/jqs.f90 index 816f274b9..363b80333 100644 --- a/src/lib/lib9290/jqs.f90 +++ b/src/lib/lib9290/jqs.f90 @@ -1,6 +1,6 @@ !!*********************************************************************** ! * - INTEGER FUNCTION JQS (IWHICH, ISUBSH, ICSF) + INTEGER FUNCTION JQS (IWHICH, ISUBSH, ICSF) ! * ! JQS is a subshell quantum number for subshell ISUBSH in configu- * ! ration state function ICSF: the seniority if IWHICH is 1; the * @@ -10,11 +10,11 @@ INTEGER FUNCTION JQS (IWHICH, ISUBSH, ICSF) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:50 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:50 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW USE STAT_C, ONLY: JQSA @@ -24,12 +24,12 @@ INTEGER FUNCTION JQS (IWHICH, ISUBSH, ICSF) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !----------------------------------------------- ! jqs = jqsa(isubsh,iwhich,icsf) ! - RETURN - END FUNCTION JQS + RETURN + END FUNCTION JQS diff --git a/src/lib/lib9290/jqs_I.f90 b/src/lib/lib9290/jqs_I.f90 index aa73fa2ab..245fb8bb2 100644 --- a/src/lib/lib9290/jqs_I.f90 +++ b/src/lib/lib9290/jqs_I.f90 @@ -1,13 +1,13 @@ - MODULE jqs_I + MODULE jqs_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:50 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:50 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER FUNCTION jqs (IWHICH, ISUBSH, ICSF) - INTEGER :: IWHICH - INTEGER, INTENT(IN) :: ISUBSH - INTEGER :: ICSF + INTEGER FUNCTION jqs (IWHICH, ISUBSH, ICSF) + INTEGER :: IWHICH + INTEGER, INTENT(IN) :: ISUBSH + INTEGER :: ICSF !VAST...Calls: JQSA - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ldigit.f90 b/src/lib/lib9290/ldigit.f90 index e13db6295..d30884e2f 100644 --- a/src/lib/lib9290/ldigit.f90 +++ b/src/lib/lib9290/ldigit.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - LOGICAL FUNCTION LDIGIT (CST) + LOGICAL FUNCTION LDIGIT (CST) ! * ! .TRUE. if CST is the ASCII representation of a decimal digit; * ! .FALSE. otherwise. * @@ -8,33 +8,33 @@ LOGICAL FUNCTION LDIGIT (CST) ! Written by Farid A. Parpia Last revised: 16 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - CHARACTER , INTENT(IN) :: CST + CHARACTER , INTENT(IN) :: CST !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - CHARACTER, DIMENSION(0:9) :: CDGT + INTEGER :: I + CHARACTER, DIMENSION(0:9) :: CDGT !----------------------------------------------- ! ! ! - DATA CDGT/ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ + DATA CDGT/ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ ! - DO I = 0, 9 - IF (CST /= CDGT(I)) CYCLE - LDIGIT = .TRUE. - GO TO 2 - END DO - LDIGIT = .FALSE. + DO I = 0, 9 + IF (CST /= CDGT(I)) CYCLE + LDIGIT = .TRUE. + GO TO 2 + END DO + LDIGIT = .FALSE. ! - 2 CONTINUE - RETURN - END FUNCTION LDIGIT + 2 CONTINUE + RETURN + END FUNCTION LDIGIT diff --git a/src/lib/lib9290/ldigit_I.f90 b/src/lib/lib9290/ldigit_I.f90 index 0d8bf97b2..19015e48c 100644 --- a/src/lib/lib9290/ldigit_I.f90 +++ b/src/lib/lib9290/ldigit_I.f90 @@ -1,10 +1,10 @@ - MODULE ldigit_I + MODULE ldigit_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:48:52 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL FUNCTION ldigit (CST) - CHARACTER (LEN = 1), INTENT(IN) :: CST - END FUNCTION - END INTERFACE - END MODULE + LOGICAL FUNCTION ldigit (CST) + CHARACTER (LEN = 1), INTENT(IN) :: CST + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodcsh.f90 b/src/lib/lib9290/lodcsh.f90 index fb989b8ce..a61176378 100644 --- a/src/lib/lib9290/lodcsh.f90 +++ b/src/lib/lib9290/lodcsh.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSH(NFILE, NCORE) + SUBROUTINE LODCSH(NFILE, NCORE) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -17,88 +17,88 @@ SUBROUTINE LODCSH(NFILE, NCORE) ! ncore, nelec, nw, np(), nak(), nkl(), nkj(), nh() ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:32:39 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:32:39 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEF_C - USE ORB_C - USE TERMS_C + USE DEF_C + USE ORB_C + USE TERMS_C USE iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE prsrcn_I + USE prsrsl_I + USE prsrcn_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NFILE - INTEGER :: NCORE + INTEGER :: NFILE + INTEGER :: NCORE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER :: IQADUM, NPEEL, I, J, NPJ, NAKJ, IOS, IERR - CHARACTER :: STR*256 + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER :: IQADUM, NPEEL, I, J, NPJ, NAKJ, IOS, IERR + CHARACTER :: STR*256 !----------------------------------------------- ! ! Entry message ! - WRITE (6, *) 'Loading CSF file ... Header only' + WRITE (6, *) 'Loading CSF file ... Header only' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (NFILE, 1) - NCORE = NW + CALL PRSRSL (NFILE, 1) + NCORE = NW ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (NFILE, *) - CALL PRSRSL (NFILE, 2) - NPEEL = NW - NCORE + READ (NFILE, *) + CALL PRSRSL (NFILE, 2) + NPEEL = NW - NCORE ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'lodcsh: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO - - WRITE (6, *) 'There are/is ', NW, ' relativistic subshells;' + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO + + WRITE (6, *) 'There are/is ', NW, ' relativistic subshells;' ! ! Skip the header for the list of CSFs ! - READ (NFILE, *) + READ (NFILE, *) ! ! To determine the number of electrons. This was done very much later ! in the non-block mcp program( near the end of lodcsh). In the block ! version, that will be used as a check to the value obtained below. ! - READ (NFILE, '(A)', IOSTAT=IOS) STR - CALL PRSRCN (STR, NCORE, IOCC, IERR) - BACKSPACE (NFILE) ! return to the first CSF item + READ (NFILE, '(A)', IOSTAT=IOS) STR + CALL PRSRCN (STR, NCORE, IOCC, IERR) + BACKSPACE (NFILE) ! return to the first CSF item ! Number of electrons in the peel shells - NELEC = SUM(IOCC(NCORE+1:NW)) + NELEC = SUM(IOCC(NCORE+1:NW)) ! Add the number of electrons in the core shells - NELEC = NELEC + SUM(NKJ(:NCORE)+1) - RETURN - END SUBROUTINE LODCSH + NELEC = NELEC + SUM(NKJ(:NCORE)+1) + RETURN + END SUBROUTINE LODCSH diff --git a/src/lib/lib9290/lodcsh2.f90 b/src/lib/lib9290/lodcsh2.f90 index daa863fb4..865b00782 100644 --- a/src/lib/lib9290/lodcsh2.f90 +++ b/src/lib/lib9290/lodcsh2.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSH2(NFILE, NCORE, JB) + SUBROUTINE LODCSH2(NFILE, NCORE, JB) ! ! IMPORTANT: ! ========== @@ -26,73 +26,73 @@ SUBROUTINE LODCSH2(NFILE, NCORE, JB) ! Modified by C. F. Fischer for block calculation 22 May 1997 * ! Updated by Xinghong He 08 Jul 1998 * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:13:05 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C + USE DEBUG_C + USE DEF_C USE ORB_C, ncfblock => ncf USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrcn_I - USE parsjl_I + USE prsrcn_I + USE parsjl_I USE pack_I - USE convrt_I - USE iq_I - USE jqs_I - USE jcup_I + USE convrt_I + USE iq_I + USE jqs_I + USE jcup_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER :: NCORE - INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NFILE + INTEGER :: NCORE + INTEGER, INTENT(IN) :: JB !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: LOADALL = -119 - CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: LOADALL = -119 + CHARACTER*7, PARAMETER :: MYNAME = 'LODCSH2' + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER, DIMENSION(NW2) :: IQSUB - INTEGER, DIMENSION(NNNW) :: JX + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER, DIMENSION(NW2) :: IQSUB + INTEGER, DIMENSION(NNNW) :: JX INTEGER :: NCORP1, NREC, NCF, NPEEL, I, J INTEGER :: IOS, IERR, LOC, NQS, ISPARC, NJX, IOC, IPTY INTEGER :: NQSN, NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI INTEGER :: NKJI, IFULLI, NU, JSUB, IQT, NBEG, NEND INTEGER :: LENTH, JXN, JPI, NCOREL, IQGG - LOGICAL :: EMPTY, FULL - CHARACTER :: STR*256, RECL + LOGICAL :: EMPTY, FULL + CHARACTER :: STR*256, RECL !----------------------------------------------- ! - IF (JB /= LOADALL) THEN - WRITE (6, *) 'Loading CSF File for block ', JB - ELSE - WRITE (6, *) 'Loading CSF File for ALL blocks ' - ENDIF - - NCORP1 = NCORE + 1 - NPEEL = NW - NCORE + IF (JB /= LOADALL) THEN + WRITE (6, *) 'Loading CSF File for block ', JB + ELSE + WRITE (6, *) 'Loading CSF File for ALL blocks ' + ENDIF + + NCORP1 = NCORE + 1 + NPEEL = NW - NCORE ! ! NPEEL is used as 1) number of peel orbitals (here) and ! 2) number of peel electrons (later in this routine) ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -102,354 +102,354 @@ SUBROUTINE LODCSH2(NFILE, NCORE, JB) ! ! Zero out the arrays that store packed integers - only when ncfblock>0 ! - IQA(:NNNW,:NCFBLOCK) = 0 - JQSA(:NNNW,1,:NCFBLOCK) = 0 - JQSA(:NNNW,2,:NCFBLOCK) = 0 - JQSA(:NNNW,3,:NCFBLOCK) = 0 - JCUPA(:NNNW,:NCFBLOCK) = 0 - - NCF = 0 - 3 CONTINUE - NCF = NCF + 1 -! - READ (NFILE, '(A)', IOSTAT=IOS) STR - + IQA(:NNNW,:NCFBLOCK) = 0 + JQSA(:NNNW,1,:NCFBLOCK) = 0 + JQSA(:NNNW,2,:NCFBLOCK) = 0 + JQSA(:NNNW,3,:NCFBLOCK) = 0 + JCUPA(:NNNW,:NCFBLOCK) = 0 + + NCF = 0 + 3 CONTINUE + NCF = NCF + 1 +! + READ (NFILE, '(A)', IOSTAT=IOS) STR + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This IF...READ makes the routine load the entire file (all blocks) ! by ignoring the end-of-block mark - + IF (IOS .EQ. 0 .AND. str(1:2) .EQ. ' *' .AND. jb .EQ. LOADALL) & READ (nfile, '(A)', IOSTAT = IOS) str !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (IOS==0 .AND. STR(1:2)/=' *') THEN + + IF (IOS==0 .AND. STR(1:2)/=' *') THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (STR, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 28 + CALL PRSRCN (STR, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 28 ! ! Read the J_sub and v quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting subshell quantum', & - ' number specification;' - GO TO 27 - ENDIF - LOC = LEN_TRIM(STR) - CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 27 + ' number specification;' + GO TO 27 + ENDIF + LOC = LEN_TRIM(STR) + CALL PARSJL (1, NCORE, STR, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 27 ! ! Read the X, J, and (sign of) P quantum numbers ! READ (nfile,'(A)',IOSTAT = IOS) str - IF (IOS /= 0) THEN + IF (IOS /= 0) THEN WRITE (ISTDE, *) MYNAME//': Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Zero out the arrays that store packed integers ! - IQA(:NNNW,NCF) = 0 - JQSA(:NNNW,1,NCF) = 0 - JQSA(:NNNW,2,NCF) = 0 - JQSA(:NNNW,3,NCF) = 0 - JCUPA(:NNNW,NCF) = 0 + IQA(:NNNW,NCF) = 0 + JQSA(:NNNW,1,NCF) = 0 + JQSA(:NNNW,2,NCF) = 0 + JQSA(:NNNW,3,NCF) = 0 + JCUPA(:NNNW,NCF) = 0 ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - LOC = LEN_TRIM(STR) - RECL = STR(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + LOC = LEN_TRIM(STR) + RECL = STR(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) MYNAME//': Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, STR, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) MYNAME//': Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': Subshell quantum numbers ', & 'specified incorrectly for '//STR(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) MYNAME//': Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), STR, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (ISTDE, *) MYNAME//': coupling of '//STR(1:LENTH)//& - NH(I), ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + NH(I), ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK(IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) MYNAME//': Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) MYNAME//': Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) MYNAME//': Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) MYNAME//': Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) MYNAME//': Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! - IF (NCF > 1) THEN - DO J = 1, NCF - 1 - DO I = NCORP1, NW - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (ISTDE, *) MYNAME//': Repeated CSF;' - GO TO 26 - ENDIF + IF (NCF > 1) THEN + DO J = 1, NCF - 1 + DO I = NCORP1, NW + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (ISTDE, *) MYNAME//': Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + + GO TO 3 ! - ELSE ! the record just read is either ' *' or EOF, marking + ELSE ! the record just read is either ' *' or EOF, marking ! the end of a block or end of the file ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF - - IF (NCF /= NCFBLOCK) THEN - WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK - STOP - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF + + IF (NCF /= NCFBLOCK) THEN + WRITE (ISTDE, *) MYNAME//': ncf=', NCF, 'ncfblock=', NCFBLOCK + STOP + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), STR, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), STR, LENTH) WRITE (6, *) 'Subshell '//STR(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs' - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ' in all CSFs' + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! This will act as a check now - it's been determined in lodcsh ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) ! NELEC = NCOREL+NPEEL - IF (NCOREL + NPEEL /= NELEC) THEN - WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' - STOP - ENDIF + IF (NCOREL + NPEEL /= NELEC) THEN + WRITE (ISTDE, *) MYNAME//': nelec not equal to that in lodcsh' + STOP + ENDIF WRITE (6,*)'There are ',NCF,' relativistic CSFs... load complete;' - RETURN -! - 26 CONTINUE - BACKSPACE (NFILE) - 27 CONTINUE - BACKSPACE (NFILE) - 28 CONTINUE - BACKSPACE (NFILE) - WRITE (ISTDE, *) ' CSF sequence number: ', NCF - DO I = 1, 3 + RETURN +! + 26 CONTINUE + BACKSPACE (NFILE) + 27 CONTINUE + BACKSPACE (NFILE) + 28 CONTINUE + BACKSPACE (NFILE) + WRITE (ISTDE, *) ' CSF sequence number: ', NCF + DO I = 1, 3 READ (nfile,'(A)',ERR = 29,END = 29) str - WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) - END DO + WRITE (ISTDE, *) STR(1:LEN_TRIM(STR)) + END DO 29 continue - CLOSE(NFILE) - - STOP - END SUBROUTINE LODCSH2 + CLOSE(NFILE) + + STOP + END SUBROUTINE LODCSH2 diff --git a/src/lib/lib9290/lodcsh2_I.f90 b/src/lib/lib9290/lodcsh2_I.f90 index 82e701bc6..5068c8630 100644 --- a/src/lib/lib9290/lodcsh2_I.f90 +++ b/src/lib/lib9290/lodcsh2_I.f90 @@ -1,12 +1,12 @@ - MODULE lodcsh2_I + MODULE lodcsh2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcsh2(NFILE, NCORE, JB) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(OUT) :: NCORE + SUBROUTINE lodcsh2(NFILE, NCORE, JB) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(OUT) :: NCORE INTEGER , INTENT(IN) :: JB - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodcsh_I.f90 b/src/lib/lib9290/lodcsh_I.f90 index f97b0dd8b..762819204 100644 --- a/src/lib/lib9290/lodcsh_I.f90 +++ b/src/lib/lib9290/lodcsh_I.f90 @@ -1,11 +1,11 @@ - MODULE lodcsh_I + MODULE lodcsh_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcsh (NFILE, NCORE) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(OUT) :: NCORE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE lodcsh (NFILE, NCORE) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(OUT) :: NCORE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodcsl.f90 b/src/lib/lib9290/lodcsl.f90 index a70d5d7cb..721b2a8c9 100644 --- a/src/lib/lib9290/lodcsl.f90 +++ b/src/lib/lib9290/lodcsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODCSL(NCORE) + SUBROUTINE LODCSL(NCORE) ! * ! Loads the data from the .csl file. A number of checks are made * ! to ensure correctness and consistency. * @@ -15,113 +15,113 @@ SUBROUTINE LODCSL(NCORE) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE ORB_C + USE DEBUG_C + USE DEF_C + USE ORB_C USE STAT_C - USE TERMS_C, only: jtab, ntab - USE IOUNIT_C + USE TERMS_C, only: jtab, ntab + USE IOUNIT_C USE BLK_C, only: NBLOCK,NCFBLK USE memory_man !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE prsrsl_I - USE convrt_I - USE prsrcn_I - USE parsjl_I - USE pack_I - USE iq_I - USE jqs_I - USE jcup_I - USE itjpo_I - USE ispar_I + USE prsrsl_I + USE convrt_I + USE prsrcn_I + USE parsjl_I + USE pack_I + USE iq_I + USE jqs_I + USE jcup_I + USE itjpo_I + USE ispar_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: NCORE + INTEGER, INTENT(OUT) :: NCORE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: NW2 = 2*NNNW + INTEGER, PARAMETER :: NW2 = 2*NNNW !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: IOCC - INTEGER, DIMENSION(NW2) :: IQSUB - INTEGER, DIMENSION(NNNW) :: JX + INTEGER, DIMENSION(NNNW) :: IOCC + INTEGER, DIMENSION(NW2) :: IQSUB + INTEGER, DIMENSION(NNNW) :: JX INTEGER :: I INTEGER :: NCORP1, NPEEL, NPEEL2, J, NPJ, NAKJ, LENTH, NCFD, NREC & , IOS, IERR, LOC, NQS, NEWSIZ, ISPARC, NJX, IOC, IPTY, NQSN & , NJXN, NPEELN, NOPEN, JLAST, ILAST, IOCCI, NKJI, IFULLI, NU & - , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL - LOGICAL :: EMPTY, FULL - CHARACTER :: RECL - CHARACTER(LEN=256) :: RECORD + , JSUB, IQT, NBEG, NEND, JXN, JPI, II, ITEMP, NCOREL + LOGICAL :: EMPTY, FULL + CHARACTER :: RECL + CHARACTER(LEN=256) :: RECORD !----------------------------------------------- ! ! ! Entry message ! - WRITE (6, *) 'Loading Configuration Symmetry List File ...' + WRITE (6, *) 'Loading Configuration Symmetry List File ...' ! ! Get the list of subshells ! - NW = 0 + NW = 0 ! ! Read the list of core subshells; set up the arrays NP, NAK, ! NKL, NKJ, NH for these subshells ! - CALL PRSRSL (21, 1) - NCORE = NW - NCORP1 = NW + 1 + CALL PRSRSL (21, 1) + NCORE = NW + NCORP1 = NW + 1 ! ! Skip the peel subshell identification header; read the list of ! peel subshells; set up the arrays NP, NAK, NKL, NKJ, NH for ! these subshells ! - READ (21, *) - CALL PRSRSL (21, 2) - NPEEL = NW - NCORE - NPEEL2 = NPEEL*2 + READ (21, *) + CALL PRSRSL (21, 2) + NPEEL = NW - NCORE + NPEEL2 = NPEEL*2 ! ! Ensure that the sets of core and peel subshell are disjoint ! - DO J = NCORE + 1, NW - NPJ = NP(J) - NAKJ = NAK(J) - DO I = 1, NCORE - IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE + DO J = NCORE + 1, NW + NPJ = NP(J) + NAKJ = NAK(J) + DO I = 1, NCORE + IF (NP(I)/=NPJ .OR. NAK(I)/=NAKJ) CYCLE WRITE (ISTDE, *) 'LODCSL: The lists of core and', & - ' peel subshells must form disjoint sets.' - STOP - END DO - END DO + ' peel subshells must form disjoint sets.' + STOP + END DO + END DO ! ! Print the number of relativistic subshells ! - IF (NW > 1) THEN - CALL CONVRT (NW, RECORD, LENTH) + IF (NW > 1) THEN + CALL CONVRT (NW, RECORD, LENTH) WRITE (6, *) 'There are '//RECORD(1:LENTH)// & - ' relativistic subshells;' - ELSE - WRITE (6, *) 'There is 1 relativistic subshell;' - ENDIF + ' relativistic subshells;' + ELSE + WRITE (6, *) 'There is 1 relativistic subshell;' + ENDIF ! ! Initial allocation for arrays with a dimension dependent ! on the number of CSFs; the initial allocation must be ! greater than 1 ! - NCFD = 6000 + NCFD = 6000 ! NCFD = 2 CALL ALLOC (IQA, NNNW, NCFD, 'IQA', 'LODCSL') @@ -131,12 +131,12 @@ SUBROUTINE LODCSL(NCORE) ! ! Skip the header for the list of CSFs ! - READ (21, *) + READ (21, *) ! ! NREC is the sequence number of the last record read in the ! Configuration Symmetry List File ! - NREC = 5 + NREC = 5 ! ! There must be three records for each CSF: For instance, ! @@ -168,65 +168,65 @@ SUBROUTINE LODCSL(NCORE) ! These conventions have been chosen so as to render the CSF ! specifications easily interpreted by the user ! - NCF = 0 - NBLOCK = 0 - 3 CONTINUE - NCF = NCF + 1 + NCF = 0 + NBLOCK = 0 + 3 CONTINUE + NCF = NCF + 1 ! - READ (21, '(A)', IOSTAT=IOS) RECORD + READ (21, '(A)', IOSTAT=IOS) RECORD !********************************************************************** !blk* ! To skip the border line added to mark the end of a block ! - IF (RECORD(1:2) == ' *') THEN - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -1 - READ (21, '(A)', IOSTAT=IOS) RECORD - ENDIF + IF (RECORD(1:2) == ' *') THEN + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF -1 + READ (21, '(A)', IOSTAT=IOS) RECORD + ENDIF !********************************************************************** - - IF (IOS == 0) THEN + + IF (IOS == 0) THEN ! ! Read in the occupations (q) of the peel shells; stop with a ! message if an error occurs ! - CALL PRSRCN (RECORD, NCORE, IOCC, IERR) - IF (IERR /= 0) GO TO 26 + CALL PRSRCN (RECORD, NCORE, IOCC, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the J_sub and v quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting subshell quantum', & - ' number specification;' - GO TO 26 - ENDIF - LOC = LEN_TRIM(RECORD) - CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) - IF (IERR /= 0) GO TO 26 + ' number specification;' + GO TO 26 + ENDIF + LOC = LEN_TRIM(RECORD) + CALL PARSJL (1, NCORE, RECORD, LOC, IQSUB, NQS, IERR) + IF (IERR /= 0) GO TO 26 ! ! Read the X, J, and (sign of) P quantum numbers ! - READ (21, '(A)', IOSTAT=IOS) RECORD - IF (IOS /= 0) THEN + READ (21, '(A)', IOSTAT=IOS) RECORD + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'LODCSL: Expecting intermediate ', & - 'and final angular momentum' + 'and final angular momentum' WRITE (ISTDE, *) 'quantum number and final parity ', & - 'specification;' - GO TO 26 - ENDIF + 'specification;' + GO TO 26 + ENDIF ! ! Allocate additional storage if necessary ! !CFF It is possible that this should be moved to "3 Continue" ! where NCF is incremented - IF (NCF > NCFD) THEN - NEWSIZ = NCFD + NCFD/2 + IF (NCF > NCFD) THEN + NEWSIZ = NCFD + NCFD/2 CALL RALLOC (IQA, NNNW, NEWSIZ, 'IQA', 'LODCSL') CALL RALLOC (JQSA, NNNW,3,NEWSIZ, 'JQSA', 'LODCSL') CALL RALLOC (JCUPA,NNNW, NEWSIZ, 'JCUPA', 'LODCSL') - NCFD = NEWSIZ - ENDIF + NCFD = NEWSIZ + ENDIF ! ! Zero out the arrays that store packed integers ! @@ -241,329 +241,329 @@ SUBROUTINE LODCSL(NCORE) ! Determine the parity and all intermediate and the final ! angular momentum quantum numbers ! - DO I = 256, 1, -1 - IF (RECORD(I:I) == ' ') CYCLE - LOC = I - EXIT - END DO - RECL = RECORD(LOC:LOC) - IF (RECL == '+') THEN - ISPARC = 1 - ELSE IF (RECL == '-') THEN - ISPARC = -1 - ELSE + DO I = 256, 1, -1 + IF (RECORD(I:I) == ' ') CYCLE + LOC = I + EXIT + END DO + RECL = RECORD(LOC:LOC) + IF (RECL == '+') THEN + ISPARC = 1 + ELSE IF (RECL == '-') THEN + ISPARC = -1 + ELSE WRITE (ISTDE, *) 'LODCSL: Incorrect parity ', & - 'specification;' - GO TO 26 - ENDIF - LOC = LOC - 1 + 'specification;' + GO TO 26 + ENDIF + LOC = LOC - 1 ! - CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) - IF (IERR /= 0) GO TO 26 + CALL PARSJL (2, NCORE, RECORD, LOC, JX, NJX, IERR) + IF (IERR /= 0) GO TO 26 ! ! Set the occupation and subshell quantum number array elements ! in IQ, JQS for the core subshells ! - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) - END DO + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (1, I, JQSA(1:NNNW,3,NCF)) + END DO ! ! Check all subshell, intermediate and final angular momentum ! quantum numbers; set the array elements in IQ, JQS for the peel ! subshells; set the coupling array element in JCUP and the total ! angular momentum array element in ITJPO ! - IOC = 0 - IPTY = 0 - NQSN = 0 - NJXN = 0 - NPEELN = 0 - NOPEN = 0 - JLAST = 0 - ILAST = 0 - DO I = NCORP1, NW - IOCCI = IOCC(I) - NPEELN = NPEELN + IOCCI - NKJI = NKJ(I) - IFULLI = NKJI + 1 - EMPTY = IOCCI == 0 - IF (.NOT.EMPTY) IOC = IOC + 1 - FULL = IOCCI == IFULLI - IF (EMPTY .OR. FULL) THEN - NU = 0 - JSUB = 0 - ELSE - IPTY = IPTY + NKL(I)*IOCCI - IF (NKJI /= 7) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + IOC = 0 + IPTY = 0 + NQSN = 0 + NJXN = 0 + NPEELN = 0 + NOPEN = 0 + JLAST = 0 + ILAST = 0 + DO I = NCORP1, NW + IOCCI = IOCC(I) + NPEELN = NPEELN + IOCCI + NKJI = NKJ(I) + IFULLI = NKJI + 1 + EMPTY = IOCCI == 0 + IF (.NOT.EMPTY) IOC = IOC + 1 + FULL = IOCCI == IFULLI + IF (EMPTY .OR. FULL) THEN + NU = 0 + JSUB = 0 + ELSE + IPTY = IPTY + NKL(I)*IOCCI + IF (NKJI /= 7) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell quantum', & - ' numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - IF (IOCCI /= 4) THEN - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + ' numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + IF (IOCCI /= 4) THEN + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - NU = 0 - JSUB = IQSUB(NQSN) - ELSE - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + NU = 0 + JSUB = IQSUB(NQSN) + ELSE + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell ', & - 'quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - IF (JSUB==4 .OR. JSUB==8) THEN - NU = JSUB/2 - NQSN = NQSN + 1 - IF (NQSN > NQS) THEN + 'quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + IF (JSUB==4 .OR. JSUB==8) THEN + NU = JSUB/2 + NQSN = NQSN + 1 + IF (NQSN > NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too few subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JSUB = IQSUB(NQSN) - ELSE - NU = 0 - ENDIF - ENDIF - ENDIF - IQT = MIN(IOCCI,IFULLI - IOCCI) - LOC = (IFULLI - 2)/2 - LOC = (LOC*(LOC + 1))/2 + IQT - NBEG = JTAB(LOC+1) + 1 - NEND = JTAB(LOC+2) - DO J = NBEG, NEND, 3 - IF (NTAB(J+2) /= JSUB + 1) CYCLE - IF (NU == 0) THEN - NU = NTAB(J) - GO TO 9 - ELSE - IF (NTAB(J) == NU) GO TO 9 - ENDIF - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JSUB = IQSUB(NQSN) + ELSE + NU = 0 + ENDIF + ENDIF + ENDIF + IQT = MIN(IOCCI,IFULLI - IOCCI) + LOC = (IFULLI - 2)/2 + LOC = (LOC*(LOC + 1))/2 + IQT + NBEG = JTAB(LOC+1) + 1 + NEND = JTAB(LOC+2) + DO J = NBEG, NEND, 3 + IF (NTAB(J+2) /= JSUB + 1) CYCLE + IF (NU == 0) THEN + NU = NTAB(J) + GO TO 9 + ELSE + IF (NTAB(J) == NU) GO TO 9 + ENDIF + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) 'LODCSL: Subshell quantum numbers ', & 'specified incorrectly for '//RECORD(1:LENTH)//NH(I)//& - ' subshell.' - GO TO 26 - ENDIF - 9 CONTINUE - IF (.NOT.EMPTY .AND. .NOT.FULL) THEN - NOPEN = NOPEN + 1 - IF (NOPEN > 1) THEN - IF (JSUB == 0) THEN - JXN = JLAST - ELSE - ILAST = IOC - NJXN = NJXN + 1 - IF (NJXN > NJX) THEN + ' subshell.' + GO TO 26 + ENDIF + 9 CONTINUE + IF (.NOT.EMPTY .AND. .NOT.FULL) THEN + NOPEN = NOPEN + 1 + IF (NOPEN > 1) THEN + IF (JSUB == 0) THEN + JXN = JLAST + ELSE + ILAST = IOC + NJXN = NJXN + 1 + IF (NJXN > NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too few intermediate', & ' and final angular momentum', & - ' quantum numbers specified;' - GO TO 26 - ENDIF - JXN = JX(NJXN) - DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 - IF (JXN == J) GO TO 11 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + ' quantum numbers specified;' + GO TO 26 + ENDIF + JXN = JX(NJXN) + DO J = ABS(JLAST - JSUB), JLAST + JSUB, 2 + IF (JXN == J) GO TO 11 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (ISTDE, *) & 'LODCSL: coupling of '//RECORD(1:LENTH)//NH(I),& - ' subshell to previous subshells is incorrect.' - GO TO 26 - ENDIF - 11 CONTINUE - CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) - JLAST = JXN - ELSE - JLAST = JSUB - ENDIF - ENDIF - CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) - CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) - CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) - CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) - END DO -! - DO I = MAX(1,NOPEN), NW - CALL PACK (0, I, JCUPA(1:NNNW,NCF)) - END DO -! - IF (NQSN /= NQS) THEN + ' subshell to previous subshells is incorrect.' + GO TO 26 + ENDIF + 11 CONTINUE + CALL PACK (JXN + 1, NOPEN - 1, JCUPA(1:NNNW,NCF)) + JLAST = JXN + ELSE + JLAST = JSUB + ENDIF + ENDIF + CALL PACK (IOCCI, I, IQA(1:NNNW,NCF)) + CALL PACK (NU, I, JQSA(1:NNNW,1,NCF)) + CALL PACK (0, I, JQSA(1:NNNW,2,NCF)) + CALL PACK (JSUB + 1, I, JQSA(1:NNNW,3,NCF)) + END DO +! + DO I = MAX(1,NOPEN), NW + CALL PACK (0, I, JCUPA(1:NNNW,NCF)) + END DO +! + IF (NQSN /= NQS) THEN WRITE (ISTDE, *) 'LODCSL: Too many subshell', & - ' quantum numbers specified;' - GO TO 26 - ENDIF + ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (ILAST /= IOC) NJXN = NJXN + 1 - IF (NJXN /= NJX) THEN + IF (ILAST /= IOC) NJXN = NJXN + 1 + IF (NJXN /= NJX) THEN WRITE (ISTDE, *) 'LODCSL: Too many intermediate', & - ' and final angular momentum', ' quantum numbers specified;' - GO TO 26 - ENDIF + ' and final angular momentum', ' quantum numbers specified;' + GO TO 26 + ENDIF ! - IF (JX(NJXN) /= JLAST) THEN + IF (JX(NJXN) /= JLAST) THEN WRITE (ISTDE, *) 'LODCSL: Final angular momentum', & - ' incorrectly specified;' - GO TO 26 - ENDIF + ' incorrectly specified;' + GO TO 26 + ENDIF ! - IPTY = (-1)**IPTY - IF (IPTY /= ISPARC) THEN - WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' - GO TO 26 - ENDIF + IPTY = (-1)**IPTY + IF (IPTY /= ISPARC) THEN + WRITE (ISTDE, *) 'LODCSL: Parity specified incorrectly;' + GO TO 26 + ENDIF ! - JPI = (JLAST + 1)*IPTY - CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) + JPI = (JLAST + 1)*IPTY + CALL PACK (JPI, NNNW, JCUPA(1:NNNW,NCF)) ! - IF (NCF > 1) THEN - IF (NPEELN /= NPEEL) THEN + IF (NCF > 1) THEN + IF (NPEELN /= NPEEL) THEN WRITE (ISTDE, *) 'LODCSL: Inconsistency in the number', & - ' of electrons.' - GO TO 26 - ENDIF - ELSE - NPEEL = NPEELN - ENDIF + ' of electrons.' + GO TO 26 + ENDIF + ELSE + NPEEL = NPEELN + ENDIF ! ! Check if this CSF was already in the list; stop with a ! message if this is the case ! - IF (NCF > 1) THEN - DO J = 1, NCF - 1 - DO I = NCORP1, NW - IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 - IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 - IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 - IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 - END DO - DO I = 1, NOPEN - 1 - IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 - END DO - END DO - WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' - GO TO 26 - ENDIF + IF (NCF > 1) THEN + DO J = 1, NCF - 1 + DO I = NCORP1, NW + IF (IQ(I,J) /= IQ(I,NCF)) GO TO 17 + IF (JQS(1,I,J) /= JQS(1,I,NCF)) GO TO 17 + IF (JQS(2,I,J) /= JQS(2,I,NCF)) GO TO 17 + IF (JQS(3,I,J) /= JQS(3,I,NCF)) GO TO 17 + END DO + DO I = 1, NOPEN - 1 + IF (JCUP(I,J) /= JCUP(I,NCF)) GO TO 17 + END DO + END DO + WRITE (ISTDE, *) 'LODCSL: Repeated CSF;' + GO TO 26 + ENDIF ! ! Successfully read a CSF; update NREC and read another CSF ! - 17 CONTINUE - NREC = NREC + 3 - GO TO 3 + 17 CONTINUE + NREC = NREC + 3 + GO TO 3 ! - ELSE + ELSE ! ! There is always at least one CSF ! - IF (NCF == 1) THEN - DO I = 1, NCORE - CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) - CALL PACK (0, I, JQSA(1:NNNW,1,1)) - CALL PACK (0, I, JQSA(1:NNNW,2,1)) - CALL PACK (1, I, JQSA(1:NNNW,3,1)) - END DO - CALL PACK (0, 1, JCUPA(1:NNNW,1)) - CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) - ELSE - NCF = NCF - 1 - ENDIF -! - ENDIF + IF (NCF == 1) THEN + DO I = 1, NCORE + CALL PACK (NKJ(I) + 1, I, IQA(1:NNNW,1)) + CALL PACK (0, I, JQSA(1:NNNW,1,1)) + CALL PACK (0, I, JQSA(1:NNNW,2,1)) + CALL PACK (1, I, JQSA(1:NNNW,3,1)) + END DO + CALL PACK (0, 1, JCUPA(1:NNNW,1)) + CALL PACK (1, NNNW, JCUPA(1:NNNW,1)) + ELSE + NCF = NCF - 1 + ENDIF +! + ENDIF ! ! Check if any subshell is empty; eliminate it from the ! list if this is the case; issue a message ! - I = NCORP1 - 19 CONTINUE - IF (I <= NW) THEN - DO J = 1, NCF - IF (IQ(I,J) /= 0) GO TO 23 - END DO - CALL CONVRT (NP(I), RECORD, LENTH) + I = NCORP1 + 19 CONTINUE + IF (I <= NW) THEN + DO J = 1, NCF + IF (IQ(I,J) /= 0) GO TO 23 + END DO + CALL CONVRT (NP(I), RECORD, LENTH) WRITE (6, *) 'Subshell '//RECORD(1:LENTH)//NH(I)//' is empty', & - ' in all CSFs; eliminating this', ' subshell from the list;' - NW = NW - 1 - DO II = I, NW - NP(II) = NP(II+1) - NAK(II) = NAK(II+1) - NKL(II) = NKL(II+1) - NKJ(II) = NKJ(II+1) - NH(II) = NH(II+1) - DO J = 1, NCF - ITEMP = IQ(II + 1,J) + ' in all CSFs; eliminating this', ' subshell from the list;' + NW = NW - 1 + DO II = I, NW + NP(II) = NP(II+1) + NAK(II) = NAK(II+1) + NKL(II) = NKL(II+1) + NKJ(II) = NKJ(II+1) + NH(II) = NH(II+1) + DO J = 1, NCF + ITEMP = IQ(II + 1,J) CALL PACK (ITEMP, II, IQA(1:NNNW,J)) - ITEMP = JQS(1,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) - ITEMP = JQS(2,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) - ITEMP = JQS(3,II + 1,J) - CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) - END DO - END DO - 23 CONTINUE - I = I + 1 - GO TO 19 - ENDIF + ITEMP = JQS(1,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,1,J)) + ITEMP = JQS(2,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,2,J)) + ITEMP = JQS(3,II + 1,J) + CALL PACK (ITEMP, II, JQSA(II:NNNW,3,J)) + END DO + END DO + 23 CONTINUE + I = I + 1 + GO TO 19 + ENDIF ! ! Store the number of electrons in the COMMON variable ! - NCOREL = 0 - NCOREL = SUM(NKJ(:NCORE)+1) - NELEC = NCOREL + NPEEL + NCOREL = 0 + NCOREL = SUM(NKJ(:NCORE)+1) + NELEC = NCOREL + NPEEL ! ! All done; report ! - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' - WRITE (6, *) ' ... load complete;' + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (6, *) 'There are '//RECORD(1:LENTH)//' relativistic CSFs;' + WRITE (6, *) ' ... load complete;' ! ! Debug printout ! - IF (LDBPA(1)) THEN - WRITE (99, *) 'From LODCSL:' - DO I = 1, NCF - WRITE (99, *) 'CSF ', I - WRITE (99, *) 'ITJPO: ', ITJPO(I) - WRITE (99, *) 'ISPAR: ', ISPAR(I) - WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) - WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) - WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) - WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) - WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) - END DO - ENDIF - - - NBLOCK = NBLOCK + 1 - NCFBLK(NBLOCK) = NCF -! - RETURN -! - 26 CONTINUE - CALL CONVRT (NCF, RECORD, LENTH) - WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' - REWIND (21) - DO I = 1, NREC - READ (21, *) - END DO - DO I = 1, 3 + IF (LDBPA(1)) THEN + WRITE (99, *) 'From LODCSL:' + DO I = 1, NCF + WRITE (99, *) 'CSF ', I + WRITE (99, *) 'ITJPO: ', ITJPO(I) + WRITE (99, *) 'ISPAR: ', ISPAR(I) + WRITE (99, *) 'IQ: ', (IQ(J,I),J=1,NW) + WRITE (99, *) 'JQS(1): ', (JQS(1,J,I),J=1,NW) + WRITE (99, *) 'JQS(2): ', (JQS(2,J,I),J=1,NW) + WRITE (99, *) 'JQS(3): ', (JQS(3,J,I),J=1,NW) + WRITE (99, *) 'JCUP: ', (JCUP(J,I),J=1,NW - 1) + END DO + ENDIF + + + NBLOCK = NBLOCK + 1 + NCFBLK(NBLOCK) = NCF +! + RETURN +! + 26 CONTINUE + CALL CONVRT (NCF, RECORD, LENTH) + WRITE (ISTDE, *) ' CSF sequence number: '//RECORD(1:LENTH)//':' + REWIND (21) + DO I = 1, NREC + READ (21, *) + END DO + DO I = 1, 3 READ (21,'(A)',ERR = 29,END = 29) RECORD - LENTH = LEN_TRIM(RECORD) - WRITE (ISTDE, *) RECORD(1:LENTH) - END DO - 29 CLOSE(21) - STOP + LENTH = LEN_TRIM(RECORD) + WRITE (ISTDE, *) RECORD(1:LENTH) + END DO + 29 CLOSE(21) + STOP ! - END SUBROUTINE LODCSL + END SUBROUTINE LODCSL diff --git a/src/lib/lib9290/lodcsl_I.f90 b/src/lib/lib9290/lodcsl_I.f90 index 7c90ec521..5f2a3c282 100644 --- a/src/lib/lib9290/lodcsl_I.f90 +++ b/src/lib/lib9290/lodcsl_I.f90 @@ -1,10 +1,10 @@ - MODULE lodcsl_I + MODULE lodcsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 13:07:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodcsl (NCORE) - INTEGER, INTENT(OUT) :: NCORE + SUBROUTINE lodcsl (NCORE) + INTEGER, INTENT(OUT) :: NCORE !VAST.../DEBUGA/ LDBPA(IN) !VAST.../DEF1/ NELEC(OUT) !VAST.../ORB2/ NCF(OUT), NW(OUT), PNTRIQ(INOUT) @@ -18,6 +18,6 @@ SUBROUTINE lodcsl (NCORE) !VAST...Calls: PRSRSL, CONVRT, ALLOC, PRSRCN, PARSJL, RALC2D !VAST...Calls: PACK, IQ, JQS, JCUP, ITJPO, ISPAR !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodiso.f90 b/src/lib/lib9290/lodiso.f90 index d94543f1d..f2196e551 100644 --- a/src/lib/lib9290/lodiso.f90 +++ b/src/lib/lib9290/lodiso.f90 @@ -1,73 +1,73 @@ !*********************************************************************** ! * - SUBROUTINE LODISO + SUBROUTINE LODISO ! * ! Loads the data from the .iso file. * ! * ! Written by Farid A. Parpia Last revision: 29 Sep 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE NPAR_C - USE NSMDAT_C, ONLY: SQN, DMOMNM, QMOMB + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE NPAR_C + USE NSMDAT_C, ONLY: SQN, DMOMNM, QMOMB IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: A, APARM, CPARM, EMNAMU + REAL(DOUBLE) :: A, APARM, CPARM, EMNAMU ! ! Read and echo pertinent information from .iso file ! ! Atomic number ! - READ (22, *) Z + READ (22, *) Z ! ! Nuclear geometry ! - READ (22, *) - READ (22, *) A - READ (22, *) - READ (22, *) APARM - READ (22, *) - READ (22, *) CPARM + READ (22, *) + READ (22, *) A + READ (22, *) + READ (22, *) APARM + READ (22, *) + READ (22, *) CPARM ! - IF (A /= 0.D0) THEN - NPARM = 2 - PARM(1) = CPARM*FMTOAU - PARM(2) = APARM*FMTOAU - ELSE - NPARM = 0 - ENDIF + IF (A /= 0.D0) THEN + NPARM = 2 + PARM(1) = CPARM*FMTOAU + PARM(2) = APARM*FMTOAU + ELSE + NPARM = 0 + ENDIF ! ! Nuclear mass ! - READ (22, *) - READ (22, *) EMNAMU + READ (22, *) + READ (22, *) EMNAMU ! - IF (EMNAMU /= 0.D0) THEN - EMN = EMNAMU/AUMAMU - ELSE - EMN = 0.D0 - ENDIF + IF (EMNAMU /= 0.D0) THEN + EMN = EMNAMU/AUMAMU + ELSE + EMN = 0.D0 + ENDIF ! ! Nuclear spin and moments ! - READ (22, *) - READ (22, *) SQN - READ (22, *) - READ (22, *) DMOMNM - READ (22, *) - READ (22, *) QMOMB + READ (22, *) + READ (22, *) SQN + READ (22, *) + READ (22, *) DMOMNM + READ (22, *) + READ (22, *) QMOMB ! ! Grid parameters from isodata ! Jon Grumer (Lund, 2013) @@ -80,6 +80,6 @@ SUBROUTINE LODISO ! READ (22,*) HP ! READ (22,*) ! READ (22,*) N - - RETURN - END SUBROUTINE LODISO + + RETURN + END SUBROUTINE LODISO diff --git a/src/lib/lib9290/lodiso_I.f90 b/src/lib/lib9290/lodiso_I.f90 index ce590d3cf..e1c940acc 100644 --- a/src/lib/lib9290/lodiso_I.f90 +++ b/src/lib/lib9290/lodiso_I.f90 @@ -1,14 +1,14 @@ - MODULE lodiso_I + MODULE lodiso_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:53 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:53 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodiso + SUBROUTINE lodiso !VAST.../DEF1/ EMN(OUT), Z(INOUT) !VAST.../DEF11/ FMTOAU(IN), AUMAMU(IN) !VAST.../NPAR/ PARM(OUT), NPARM(OUT) !VAST.../NSMDAT/ SQN(INOUT), DMOMNM(INOUT), QMOMB(INOUT) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodrwf.f90 b/src/lib/lib9290/lodrwf.f90 index 9088a3329..fb744b0ab 100644 --- a/src/lib/lib9290/lodrwf.f90 +++ b/src/lib/lib9290/lodrwf.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LODRWF(IIERR) + SUBROUTINE LODRWF(IIERR) ! * ! This subroutine loads radial wavefunctions from the .rwf file * ! and performs some related setup. * @@ -11,26 +11,26 @@ SUBROUTINE LODRWF(IIERR) ! Block version by Xinghong He Last revision: 27 May 1997 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:43 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:24:43 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP USE memory_man - USE DEBUG_C - USE DEF_C, ONLY: C, Z - USE GRID_C - USE NPAR_C - USE ORB_C - USE WAVE_C, ONLY: PZ, PF,QF + USE DEBUG_C + USE DEF_C, ONLY: C, Z + USE GRID_C + USE NPAR_C + USE ORB_C + USE WAVE_C, ONLY: PZ, PF,QF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE intrpq_I - USE orthsc_I + USE intrpq_I + USE orthsc_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -38,20 +38,20 @@ SUBROUTINE LODRWF(IIERR) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: IIERR + INTEGER, INTENT(OUT) :: IIERR !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, K, NWIN, IOS, NPY, NAKY, MY + INTEGER :: J, I, K, NWIN, IOS, NPY, NAKY, MY integer :: ierr - REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM + REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM real(double), dimension(:), pointer :: PA, QA, RA !----------------------------------------------- ! ! ! Write entry message ! - WRITE (6, *) 'Loading Radial WaveFunction File ...' + WRITE (6, *) 'Loading Radial WaveFunction File ...' ! ! Allocate storage to orbital arrays ! @@ -63,83 +63,83 @@ SUBROUTINE LODRWF(IIERR) ! (2) Array E to -1 (no orbitals estimated) ! (3) Parameters GAMMA for each orbital ! - CON = Z/C - CON = CON*CON + CON = Z/C + CON = CON*CON ! - DO J = 1, NW + DO J = 1, NW ! - PF(:N,J) = 0.0D00 - QF(:N,J) = 0.0D00 + PF(:N,J) = 0.0D00 + QF(:N,J) = 0.0D00 ! - E(J) = -1.0D00 + E(J) = -1.0D00 ! - K = ABS(NAK(J)) - IF (NPARM > 0) THEN - GAMA(J) = DBLE(K) - ELSE IF (NPARM == 0) THEN - FKK = DBLE(K*K) - IF (FKK >= CON) THEN - GAMA(J) = SQRT(FKK - CON) - ELSE + K = ABS(NAK(J)) + IF (NPARM > 0) THEN + GAMA(J) = DBLE(K) + ELSE IF (NPARM == 0) THEN + FKK = DBLE(K*K) + IF (FKK >= CON) THEN + GAMA(J) = SQRT(FKK - CON) + ELSE !WRITE (istde,*) 'LODRWF: Imaginary gamma parameter' !WRITE (istde,*) ' for ',NP(J),NH(J),' orbital; the' !WRITE (istde,*) ' point model for the nucleus' !WRITE (istde,*) ' is inappropriate for Z > ',C,'.' - STOP 'lodrwf: Inappropriate gamma' - ENDIF - ENDIF + STOP 'lodrwf: Inappropriate gamma' + ENDIF + ENDIF ! - END DO + END DO ! ! Read orbital information from Read Orbitals File; write summary ! to .dbg file if option set ! - IF (LDBPR(3)) WRITE (99, 300) - NWIN = 0 - 3 CONTINUE - READ (23, IOSTAT=IOS) NPY, NAKY, EY, MY - - IF (IOS == 0) THEN + IF (LDBPR(3)) WRITE (99, 300) + NWIN = 0 + 3 CONTINUE + READ (23, IOSTAT=IOS) NPY, NAKY, EY, MY + + IF (IOS == 0) THEN CALL ALLOC (PA,MY, 'PA', 'LODRWF') CALL ALLOC (QA,MY, 'QA', 'LODRWF') CALL ALLOC (RA,MY, 'RA', 'LODRWF') - - READ (23) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) - READ (23) (RA(I),I=1,MY) - - DO J = 1, NW - IF (.NOT.(E(J)<0.0D00 .AND. NPY==NP(J) .AND. NAKY==NAK(J))) CYCLE - PZ(J) = PZY - E(J) = EY - CALL INTRPQ(PA, QA, MY, RA, J, DNORM) - IF (LDBPR(3)) WRITE (99, 301) NP(J), NH(J), E(J), DNORM - NWIN = NWIN + 1 - END DO + + READ (23) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY) + READ (23) (RA(I),I=1,MY) + + DO J = 1, NW + IF (.NOT.(E(J)<0.0D00 .AND. NPY==NP(J) .AND. NAKY==NAK(J))) CYCLE + PZ(J) = PZY + E(J) = EY + CALL INTRPQ(PA, QA, MY, RA, J, DNORM) + IF (LDBPR(3)) WRITE (99, 301) NP(J), NH(J), E(J), DNORM + NWIN = NWIN + 1 + END DO CALL DALLOC (PA, 'PA', 'LODRWF' ) CALL DALLOC (QA, 'QA', 'LODRWF') CALL DALLOC (RA, 'RA', 'LODRWF') - GO TO 3 - ENDIF - IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' + GO TO 3 + ENDIF + IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;' ! ! Stop with an error message if all orbitals are not known ! - IF (NWIN < NW) THEN - IIERR = 1 - GO TO 5 - ENDIF + IF (NWIN < NW) THEN + IIERR = 1 + GO TO 5 + ENDIF ! ! Schmidt orthogonalise the orbitals ! - CALL ORTHSC - IF (LDBPR(3)) WRITE (99, *) ' orbitals orthogonalised and renormalised;' + CALL ORTHSC + IF (LDBPR(3)) WRITE (99, *) ' orbitals orthogonalised and renormalised;' ! - IIERR = 0 - 5 CONTINUE - RETURN + IIERR = 0 + 5 CONTINUE + RETURN ! - 300 FORMAT(/,'From SUBROUTINE LODRWF:'/,' Orbital',8X,'Eigenvalue',19X,'Norm') - 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) - RETURN + 300 FORMAT(/,'From SUBROUTINE LODRWF:'/,' Orbital',8X,'Eigenvalue',19X,'Norm') + 301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15) + RETURN ! - END SUBROUTINE LODRWF + END SUBROUTINE LODRWF diff --git a/src/lib/lib9290/lodrwf_I.f90 b/src/lib/lib9290/lodrwf_I.f90 index eab29f8b2..54e86c370 100644 --- a/src/lib/lib9290/lodrwf_I.f90 +++ b/src/lib/lib9290/lodrwf_I.f90 @@ -1,10 +1,10 @@ - MODULE lodrwf_I + MODULE lodrwf_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:43 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 14:24:43 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE lodrwf (IIERR) - INTEGER, INTENT(OUT) :: IIERR + SUBROUTINE lodrwf (IIERR) + INTEGER, INTENT(OUT) :: IIERR !VAST.../DEBUGR/ LDBPR(IN) !VAST.../DEF1/ Z(IN) !VAST.../DEF2/ C(IN) @@ -17,6 +17,6 @@ SUBROUTINE lodrwf (IIERR) !VAST.../WAVE/ PZ(OUT), PNTRPF(INOUT), PNTRQF(INOUT) !VAST...Calls: ALLOC, INTRPQ, DALLOC, ORTHSC !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/lodstate.f90 b/src/lib/lib9290/lodstate.f90 index 703932001..a10ad0ee5 100644 --- a/src/lib/lib9290/lodstate.f90 +++ b/src/lib/lib9290/lodstate.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE LODSTATE(IDBLK) + SUBROUTINE LODSTATE(IDBLK) ! ! Print block info and ask ASF serial numbers for each block ! @@ -18,20 +18,20 @@ SUBROUTINE LODSTATE(IDBLK) ! Updated by Xinghong He Jun 10 1998 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:30:40 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:30:40 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man - USE DEF_C + USE DEF_C USE hblock_C use iounit_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE items_I + USE items_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -40,55 +40,55 @@ SUBROUTINE LODSTATE(IDBLK) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, I, JBLOCK, NCF, NCMINOLD, IERR, NTMP - CHARACTER :: STR*256 + INTEGER :: J, I, JBLOCK, NCF, NCMINOLD, IERR, NTMP + CHARACTER :: STR*256 !----------------------------------------------- ! - + WRITE (ISTDE, *) 'There are ', NBLOCK, ' blocks ', & - '(block J/Parity NCF):' + '(block J/Parity NCF):' WRITE (ISTDE, '( 4(I3, 1X, A5, I8, 5X) )') (J,IDBLK(J)(1:5),NCFBLK(J),J=1& - ,NBLOCK) + ,NBLOCK) + + NEVBLK = 0 + NCMAXBLK = 0 + + WRITE (ISTDE, *) + WRITE (ISTDE, *) 'Enter ASF serial numbers for each block' - NEVBLK = 0 - NCMAXBLK = 0 - - WRITE (ISTDE, *) - WRITE (ISTDE, *) 'Enter ASF serial numbers for each block' - - NCMIN = 0 - 123 CONTINUE - DO JBLOCK = 1, NBLOCK - NCF = NCFBLK(JBLOCK) - 234 CONTINUE + NCMIN = 0 + 123 CONTINUE + DO JBLOCK = 1, NBLOCK + NCF = NCFBLK(JBLOCK) + 234 CONTINUE WRITE (ISTDE, *) 'Block ', JBLOCK, ' ncf = ', NCF, ' id = ', IDBLK(& - JBLOCK)(1:5) - + JBLOCK)(1:5) + ! ...Read and parse the list of levels - - READ (*, '(A)') STR + + READ (*, '(A)') STR WRITE(734,'(a)') trim(str) ! write to rscf.log file see, rscf - + ! ...ICCMIN is allocated and accumulated in items ! ...ncmin is both input and output parameters to items - NCMINOLD = NCMIN - CALL ITEMS (NCMIN, NCF, STR, IERR) - IF (NCMIN == 0) CALL DALLOC (ICCMIN, 'ICCMIN', 'LODSTATE' ) - IF (IERR < 0) GO TO 234 - NEVBLK(JBLOCK) = NCMIN - NCMINOLD - + NCMINOLD = NCMIN + CALL ITEMS (NCMIN, NCF, STR, IERR) + IF (NCMIN == 0) CALL DALLOC (ICCMIN, 'ICCMIN', 'LODSTATE' ) + IF (IERR < 0) GO TO 234 + NEVBLK(JBLOCK) = NCMIN - NCMINOLD + ! ...Determine ncmaxblk - NTMP = 0 - DO I = NCMINOLD + 1, NCMIN - NTMP = MAX(NTMP,ICCMIN(I)) - END DO - NCMAXBLK(JBLOCK) = NTMP - END DO - - IF (NCMIN == 0) THEN - WRITE (ISTDE, *) 'At least one state should be selected' - GO TO 123 - ENDIF - - RETURN - END SUBROUTINE LODSTATE + NTMP = 0 + DO I = NCMINOLD + 1, NCMIN + NTMP = MAX(NTMP,ICCMIN(I)) + END DO + NCMAXBLK(JBLOCK) = NTMP + END DO + + IF (NCMIN == 0) THEN + WRITE (ISTDE, *) 'At least one state should be selected' + GO TO 123 + ENDIF + + RETURN + END SUBROUTINE LODSTATE diff --git a/src/lib/lib9290/lodstate_I.f90 b/src/lib/lib9290/lodstate_I.f90 index 007103f75..bb7510be6 100644 --- a/src/lib/lib9290/lodstate_I.f90 +++ b/src/lib/lib9290/lodstate_I.f90 @@ -1,7 +1,7 @@ - MODULE lodstate_I + MODULE lodstate_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:58 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:58 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LODSTATE(IDBLK) CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK @@ -9,6 +9,6 @@ SUBROUTINE LODSTATE(IDBLK) !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: ITEMS, DALLOC, ICCMIN !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/ltab.f90 b/src/lib/lib9290/ltab.f90 index 28f870e88..160f93d49 100644 --- a/src/lib/lib9290/ltab.f90 +++ b/src/lib/lib9290/ltab.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE LTAB(IS, NQS, KS, IROWS) + SUBROUTINE LTAB(IS, NQS, KS, IROWS) ! * ! locates rows of possible parents of active shell states for acc- * ! essing NTAB. It is assumed that empty shells have been elimina- * @@ -9,13 +9,13 @@ SUBROUTINE LTAB(IS, NQS, KS, IROWS) ! Last update: 15 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:49:59 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:49:59 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE TERMS_C + USE TERMS_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -27,43 +27,43 @@ SUBROUTINE LTAB(IS, NQS, KS, IROWS) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(4) :: KQ - INTEGER :: KQ1, KQ2 + INTEGER, DIMENSION(4) :: KQ + INTEGER :: KQ1, KQ2 INTEGER :: I !----------------------------------------------- ! ! - IF (IS(1) == IS(2)) NQS(1) = NQS(2) - 1 - IF (IS(3) == IS(4)) NQS(3) = NQS(4) - 1 + IF (IS(1) == IS(2)) NQS(1) = NQS(2) - 1 + IF (IS(3) == IS(4)) NQS(3) = NQS(4) - 1 ! - DO I = 1, 4 + DO I = 1, 4 ! ! Check that input data are consistent ! - IF (NQS(I)<=0 .OR. NQS(I)>KS(I)) THEN - WRITE (*, 300) NQS(I), IS(I), KS(I) - STOP - ENDIF + IF (NQS(I)<=0 .OR. NQS(I)>KS(I)) THEN + WRITE (*, 300) NQS(I), IS(I), KS(I) + STOP + ENDIF ! - KQ1 = NQS(I) - 1 - KQ2 = KS(I) - KQ1 - KQ(I) = MIN(KQ1,KQ2) + 1 - IF (KQ(I) /= 1) THEN - IROWS(I) = (KS(I)*(KS(I)-2))/8 + KQ(I) - ELSE - IROWS(I) = 1 - ENDIF + KQ1 = NQS(I) - 1 + KQ2 = KS(I) - KQ1 + KQ(I) = MIN(KQ1,KQ2) + 1 + IF (KQ(I) /= 1) THEN + IROWS(I) = (KS(I)*(KS(I)-2))/8 + KQ(I) + ELSE + IROWS(I) = 1 + ENDIF ! - IF (IROWS(I) <= NROWS) CYCLE - WRITE (*, 301) - STOP + IF (IROWS(I) <= NROWS) CYCLE + WRITE (*, 301) + STOP ! - END DO + END DO ! - RETURN + RETURN ! - 300 FORMAT('LTAB: ',1I3,' Electrons in shell ',1I3,' with 2j+1 = ',1I3) - 301 FORMAT('LTAB: Extend COMMON block TERMS') - RETURN + 300 FORMAT('LTAB: ',1I3,' Electrons in shell ',1I3,' with 2j+1 = ',1I3) + 301 FORMAT('LTAB: Extend COMMON block TERMS') + RETURN ! - END SUBROUTINE LTAB + END SUBROUTINE LTAB diff --git a/src/lib/lib9290/ltab_I.f90 b/src/lib/lib9290/ltab_I.f90 index a21fc2ff8..11a254212 100644 --- a/src/lib/lib9290/ltab_I.f90 +++ b/src/lib/lib9290/ltab_I.f90 @@ -1,15 +1,15 @@ - MODULE ltab_I + MODULE ltab_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:59 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:49:59 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ltab (IS, NQS, KS, IROWS) - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(INOUT) :: NQS - INTEGER, DIMENSION(4), INTENT(IN) :: KS - INTEGER, DIMENSION(4), INTENT(INOUT) :: IROWS + SUBROUTINE ltab (IS, NQS, KS, IROWS) + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(INOUT) :: NQS + INTEGER, DIMENSION(4), INTENT(IN) :: KS + INTEGER, DIMENSION(4), INTENT(INOUT) :: IROWS !VAST.../TERMS/ NROWS(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/nucpot.f90 b/src/lib/lib9290/nucpot.f90 index a6125f325..0c27fc07f 100644 --- a/src/lib/lib9290/nucpot.f90 +++ b/src/lib/lib9290/nucpot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE NUCPOT + SUBROUTINE NUCPOT ! * ! Evaluate the nuclear potential for point and Fermi models. * ! * @@ -9,110 +9,110 @@ SUBROUTINE NUCPOT ! Written by Farid A Parpia, at Oxford Last revision: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE DEF_C, ONLY: Z, PI - USE GRID_C - USE NPAR_C - USE NPOT_C, ONLY: ZZ, NNUC + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE DEF_C, ONLY: Z, PI + USE GRID_C + USE NPAR_C + USE NPOT_C, ONLY: ZZ, NNUC !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE es_I + USE es_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, NB3, NROWS, II, II1, II2, II3 + INTEGER :: I, NB3, NROWS, II, II1, II2, II3 REAL(DOUBLE) :: C, A, ABC, TABC, ABC2, THABC2, ABC3, CBA, PI2, HPIAC2, & H3PHP, S2MCBA, S3MCBA, SABC3, DMSAS, EN, ZBN, RI, RMC, RMCBA, RBC, & - S2RCBA, S3RCBA - LOGICAL :: SET + S2RCBA, S3RCBA + LOGICAL :: SET !----------------------------------------------- ! ! ! Point nucleus ! - IF (NPARM == 0) THEN + IF (NPARM == 0) THEN ! - ZZ(:N) = Z + ZZ(:N) = Z ! ! Fermi distribution ! - ELSE IF (NPARM == 2) THEN + ELSE IF (NPARM == 2) THEN ! - C = PARM(1) - A = PARM(2) - ABC = A/C - TABC = 2.0D00*ABC - ABC2 = ABC*ABC - THABC2 = 3.0D00*ABC2 - ABC3 = ABC2*ABC - CBA = C/A - PI2 = PI*PI - HPIAC2 = 0.5D00*PI2*ABC2 - H3PHP = 1.5D00 + HPIAC2 - CALL ES ((-CBA), S2MCBA, S3MCBA) - SABC3 = 6.0D00*ABC3 - DMSAS = -SABC3*S3MCBA - EN = 1.0D00 + ABC2*PI2 + DMSAS - ZBN = Z/EN + C = PARM(1) + A = PARM(2) + ABC = A/C + TABC = 2.0D00*ABC + ABC2 = ABC*ABC + THABC2 = 3.0D00*ABC2 + ABC3 = ABC2*ABC + CBA = C/A + PI2 = PI*PI + HPIAC2 = 0.5D00*PI2*ABC2 + H3PHP = 1.5D00 + HPIAC2 + CALL ES ((-CBA), S2MCBA, S3MCBA) + SABC3 = 6.0D00*ABC3 + DMSAS = -SABC3*S3MCBA + EN = 1.0D00 + ABC2*PI2 + DMSAS + ZBN = Z/EN ! - SET = .FALSE. - DO I = 1, N - RI = R(I) - RMC = RI - C - RMCBA = RMC/A - RBC = RI/C - IF (RBC <= 1.0D00) THEN - CALL ES (RMCBA, S2RCBA, S3RCBA) + SET = .FALSE. + DO I = 1, N + RI = R(I) + RMC = RI - C + RMCBA = RMC/A + RBC = RI/C + IF (RBC <= 1.0D00) THEN + CALL ES (RMCBA, S2RCBA, S3RCBA) ZZ(I) = ZBN*(DMSAS + SABC3*S3RCBA + RBC*(H3PHP - THABC2*S2RCBA& - - 0.5D00*RBC*RBC)) - ELSE - IF (.NOT.SET) THEN - NNUC = I - SET = .TRUE. - ENDIF - CALL ES ((-RMCBA), S2RCBA, S3RCBA) - ZZ(I) = Z*(1.0D00 + THABC2*(RBC*S2RCBA + TABC*S3RCBA)/EN) - ENDIF - END DO - ENDIF + - 0.5D00*RBC*RBC)) + ELSE + IF (.NOT.SET) THEN + NNUC = I + SET = .TRUE. + ENDIF + CALL ES ((-RMCBA), S2RCBA, S3RCBA) + ZZ(I) = Z*(1.0D00 + THABC2*(RBC*S2RCBA + TABC*S3RCBA)/EN) + ENDIF + END DO + ENDIF ! - IF (LDBPR(2)) THEN - WRITE (99, 300) - NB3 = N/3 - IF (3*NB3 == N) THEN - NROWS = NB3 - ELSE - NROWS = NB3 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - II3 = II2 + NROWS - IF (II3 <= N) THEN + IF (LDBPR(2)) THEN + WRITE (99, 300) + NB3 = N/3 + IF (3*NB3 == N) THEN + NROWS = NB3 + ELSE + NROWS = NB3 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + II3 = II2 + NROWS + IF (II3 <= N) THEN WRITE (99, 301) R(II1), ZZ(II1), R(II2), ZZ(II2), R(II3), ZZ(II3& - ) - ELSE IF (II2 <= N) THEN - WRITE (99, 301) R(II1), ZZ(II1), R(II2), ZZ(II2) - ELSE - WRITE (99, 301) R(II1), ZZ(II1) - ENDIF - END DO - ENDIF + ) + ELSE IF (II2 <= N) THEN + WRITE (99, 301) R(II1), ZZ(II1), R(II2), ZZ(II2) + ELSE + WRITE (99, 301) R(II1), ZZ(II1) + ENDIF + END DO + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,'From SUBROUTINE NUCPOT:'/,3(& - ' -------- r -------- ----- -r*V(r) -----')) - 301 FORMAT(1P,6(1X,1D19.12)) - RETURN + ' -------- r -------- ----- -r*V(r) -----')) + 301 FORMAT(1P,6(1X,1D19.12)) + RETURN ! - END SUBROUTINE NUCPOT + END SUBROUTINE NUCPOT diff --git a/src/lib/lib9290/nucpot_I.f90 b/src/lib/lib9290/nucpot_I.f90 index 3f53e5cc3..3a78664a9 100644 --- a/src/lib/lib9290/nucpot_I.f90 +++ b/src/lib/lib9290/nucpot_I.f90 @@ -1,9 +1,9 @@ - MODULE nucpot_I + MODULE nucpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:02 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:02 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE nucpot + SUBROUTINE nucpot !VAST.../DEBUGR/ LDBPR(IN) !VAST.../DEF1/ Z(IN) !VAST.../DEF9/ PI(IN) @@ -12,6 +12,6 @@ SUBROUTINE nucpot !VAST.../NPOT/ ZZ(INOUT), NNUC(OUT) !VAST...Calls: ES !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/openfl.f90 b/src/lib/lib9290/openfl.f90 index 9cb21d89f..8ebe40f1d 100644 --- a/src/lib/lib9290/openfl.f90 +++ b/src/lib/lib9290/openfl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE OPENFL(NFILE, FILNAM, RFORM, RSTAT, IERR) + SUBROUTINE OPENFL(NFILE, FILNAM, RFORM, RSTAT, IERR) ! * ! Issues OPEN for file with unit number NFILE, name FILNAM, format * ! RFORM, status RSTAT. If this is successful the head is position- * @@ -12,42 +12,42 @@ SUBROUTINE OPENFL(NFILE, FILNAM, RFORM, RSTAT, IERR) ! Written by Farid A. Parpia Last revision: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:04 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:04 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE IOUNIT_C + USE IOUNIT_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(OUT) :: IERR + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(OUT) :: IERR CHARACTER (LEN = *), INTENT(IN) :: FILNAM CHARACTER (LEN = *), INTENT(IN) :: RFORM CHARACTER (LEN = *), INTENT(IN) :: RSTAT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IOS, LOC + INTEGER :: IOS, LOC !----------------------------------------------- ! ! OPEN(NFILE, FILE=FILNAM, FORM=RFORM, STATUS='UNKNOWN', IOSTAT=IOS, & - POSITION='asis') + POSITION='asis') ! - IF (IOS == 0) THEN - REWIND (NFILE) - IERR = 0 - ELSE - LOC = LEN_TRIM(FILNAM) + IF (IOS == 0) THEN + REWIND (NFILE) + IERR = 0 + ELSE + LOC = LEN_TRIM(FILNAM) WRITE (ISTDE, *) 'OPENFL: Error opening file ', FILNAM(1:LOC), ' as '& - , RSTAT, ';' - WRITE (ISTDE, *) 'The argument RSTAT=', RSTAT, ' is not used !' - IERR = 1 - ENDIF + , RSTAT, ';' + WRITE (ISTDE, *) 'The argument RSTAT=', RSTAT, ' is not used !' + IERR = 1 + ENDIF ! - RETURN - END SUBROUTINE OPENFL + RETURN + END SUBROUTINE OPENFL diff --git a/src/lib/lib9290/openfl_I.f90 b/src/lib/lib9290/openfl_I.f90 index da94b09c2..abb69c316 100644 --- a/src/lib/lib9290/openfl_I.f90 +++ b/src/lib/lib9290/openfl_I.f90 @@ -1,16 +1,16 @@ - MODULE openfl_I + MODULE openfl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:04 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:04 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE openfl (NFILE, FILNAM, RFORM, RSTAT, IERR) - INTEGER, INTENT(IN) :: NFILE - CHARACTER (LEN = *), INTENT(IN) :: FILNAM - CHARACTER (LEN = *), INTENT(IN) :: RFORM - CHARACTER (LEN = *), INTENT(IN) :: RSTAT - INTEGER, INTENT(OUT) :: IERR + SUBROUTINE openfl (NFILE, FILNAM, RFORM, RSTAT, IERR) + INTEGER, INTENT(IN) :: NFILE + CHARACTER (LEN = *), INTENT(IN) :: FILNAM + CHARACTER (LEN = *), INTENT(IN) :: RFORM + CHARACTER (LEN = *), INTENT(IN) :: RSTAT + INTEGER, INTENT(OUT) :: IERR !VAST.../IOUNIT/ ISTDE(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/orthsc.f90 b/src/lib/lib9290/orthsc.f90 index a0e14bc7e..ef3f8002a 100644 --- a/src/lib/lib9290/orthsc.f90 +++ b/src/lib/lib9290/orthsc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE ORTHSC + SUBROUTINE ORTHSC ! * ! This routine Schmidt orthogonalises radial wavefunctions. * ! * @@ -11,32 +11,32 @@ SUBROUTINE ORTHSC ! Normalization of the orbitals moved out of the inner loop ! XHH 1997.02.14 !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:41:29 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:41:29 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - USE DEBUG_C - USE DEF_C - USE GRID_C - USE ORB_C - USE WAVE_C, ONLY: PZ, MF, PF, QF + USE DEBUG_C + USE DEF_C + USE GRID_C + USE ORB_C + USE WAVE_C, ONLY: PZ, MF, PF, QF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE rint_I + USE rint_I IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(NNNW) :: J - INTEGER :: L, NAKL, KOUNT, MTP0, K, MTP, I - REAL(DOUBLE), DIMENSION(NNNW) :: OVLAP - REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR - LOGICAL :: CHANGED + INTEGER, DIMENSION(NNNW) :: J + INTEGER :: L, NAKL, KOUNT, MTP0, K, MTP, I + REAL(DOUBLE), DIMENSION(NNNW) :: OVLAP + REAL(DOUBLE) :: EPS, OVRLAP, DNORM, FACTOR + LOGICAL :: CHANGED !----------------------------------------------- ! !XHH @@ -44,7 +44,7 @@ SUBROUTINE ORTHSC ! Set tabulated values of the radial wavefunction to zero ! if they are less than EPS ! - EPS = 0.01D00*ACCY + EPS = 0.01D00*ACCY ! ! Determine the number of interesting overlaps ! @@ -59,81 +59,81 @@ SUBROUTINE ORTHSC ! ! IF (NOVL .EQ. 0) RETURN ! - DO L = 2, NW + DO L = 2, NW ! - NAKL = NAK(L) - KOUNT = 0 + NAKL = NAK(L) + KOUNT = 0 !XHH MTP0 introduced to count the maximum number of points during ! orthogonalization of the L-th orbital to other orbitals ! The logical variable changed is initialized to .F. - - MTP0 = MF(L) - CHANGED = .FALSE. + + MTP0 = MF(L) + CHANGED = .FALSE. ! - DO K = 1, L - 1 + DO K = 1, L - 1 ! - IF (NAK(K) /= NAKL) CYCLE + IF (NAK(K) /= NAKL) CYCLE !XHH - CHANGED = .TRUE. + CHANGED = .TRUE. ! ! Compute overlap ! - OVRLAP = RINT(L,K,0) + OVRLAP = RINT(L,K,0) ! ! Schmidt orthogonalise ! - KOUNT = KOUNT + 1 - J(KOUNT) = K - OVLAP(KOUNT) = OVRLAP + KOUNT = KOUNT + 1 + J(KOUNT) = K + OVLAP(KOUNT) = OVRLAP ! - PZ(L) = PZ(L) - OVRLAP*PZ(K) - MTP = MAX(MF(L),MF(K)) - MTP0 = MAX(MTP0,MF(K)) - - PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) - QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) - END DO + PZ(L) = PZ(L) - OVRLAP*PZ(K) + MTP = MAX(MF(L),MF(K)) + MTP0 = MAX(MTP0,MF(K)) + + PF(:MTP,L) = PF(:MTP,L) - OVRLAP*PF(:MTP,K) + QF(:MTP,L) = QF(:MTP,L) - OVRLAP*QF(:MTP,K) + END DO ! ! Normalise ! !XHH Use MTP0 to replace MTP and only when the orbital is changed. ! This is in accordance with the original version which had the ! normalization etc within the inner K loop. - - IF (CHANGED) THEN - MTP = MTP0 - - MF(L) = MTP - DNORM = RINT(L,L,0) - FACTOR = 1.0D00/SQRT(DNORM) -! - PZ(L) = FACTOR*PZ(L) - PF(2:MTP,L) = FACTOR*PF(2:MTP,L) - QF(2:MTP,L) = FACTOR*QF(2:MTP,L) + + IF (CHANGED) THEN + MTP = MTP0 + + MF(L) = MTP + DNORM = RINT(L,L,0) + FACTOR = 1.0D00/SQRT(DNORM) +! + PZ(L) = FACTOR*PZ(L) + PF(2:MTP,L) = FACTOR*PF(2:MTP,L) + QF(2:MTP,L) = FACTOR*QF(2:MTP,L) ! ! Find new MF(L) ! - MTP = MTP + 1 - 7 CONTINUE - MTP = MTP - 1 -!cjb print *, ' MTP = ', MTP -! print *, ' L = ', L + MTP = MTP + 1 + 7 CONTINUE + MTP = MTP - 1 +!cjb print *, ' MTP = ', MTP +! print *, ' L = ', L ! print *, ' PF(MTP,L) = ', PF(MTP,L) !cjb Subscript out of range for array pf if ( MTP .GE. 1 ) then !cjb - IF (ABS(PF(MTP,L)) < EPS) THEN - PF(MTP,L) = 0.0D00 - QF(MTP,L) = 0.0D00 - GO TO 7 - ELSE - MF(L) = MTP - ENDIF + IF (ABS(PF(MTP,L)) < EPS) THEN + PF(MTP,L) = 0.0D00 + QF(MTP,L) = 0.0D00 + GO TO 7 + ELSE + MF(L) = MTP + ENDIF !cjb endif endif - ENDIF - IF (.NOT.(LDBPR(3) .AND. KOUNT>0)) CYCLE - + ENDIF + IF (.NOT.(LDBPR(3) .AND. KOUNT>0)) CYCLE + !XHH Moved ahead ! ENDIF ! 8 CONTINUE @@ -157,13 +157,13 @@ SUBROUTINE ORTHSC ! WRITE (*,301) ! : (OVLAP(I),NP(L),NH(L),NP(J(I)),NH(J(I)),I = 1,KOUNT) !--------------------------------------------------------------- - WRITE (99, 301) (OVLAP(I),NP(L),NH(L),NP(J(I)),NH(J(I)),I=1,KOUNT) + WRITE (99, 301) (OVLAP(I),NP(L),NH(L),NP(J(I)),NH(J(I)),I=1,KOUNT) ! - END DO + END DO ! - RETURN + RETURN ! - 301 FORMAT(1P,5(2X,1D10.3,' = <',1I2,1A2,'|',1I2,1A2,'>')) - RETURN + 301 FORMAT(1P,5(2X,1D10.3,' = <',1I2,1A2,'|',1I2,1A2,'>')) + RETURN ! - END SUBROUTINE ORTHSC + END SUBROUTINE ORTHSC diff --git a/src/lib/lib9290/orthsc_I.f90 b/src/lib/lib9290/orthsc_I.f90 index 8ea4f2b04..0c961fea7 100644 --- a/src/lib/lib9290/orthsc_I.f90 +++ b/src/lib/lib9290/orthsc_I.f90 @@ -1,9 +1,9 @@ - MODULE orthsc_I + MODULE orthsc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:41:29 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:41:29 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE orthsc + SUBROUTINE orthsc !VAST.../DEBUGR/ LDBPR(IN) !VAST.../DEF4/ ACCY(IN) !VAST.../ORB2/ NW(IN) @@ -12,6 +12,6 @@ SUBROUTINE orthsc !VAST.../WAVE/ PZ(INOUT), MF(INOUT) !VAST...Calls: RINT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/pack.f90 b/src/lib/lib9290/pack.f90 index cc900cf55..18dab9418 100644 --- a/src/lib/lib9290/pack.f90 +++ b/src/lib/lib9290/pack.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PACK(IUNPKD, ISUBSH, IPACKD) + SUBROUTINE PACK(IUNPKD, ISUBSH, IPACKD) ! * ! Subshell occupation numbers and all angular momenta 2J+1 are not * ! likely to exceed 127 in any application of the GRASP92 suite. It * @@ -19,36 +19,36 @@ SUBROUTINE PACK(IUNPKD, ISUBSH, IPACKD) ! Modified by G. Gaigalas May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:08 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:08 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: BYTE - USE IOUNIT_C + USE IOUNIT_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: IUNPKD - INTEGER, INTENT(IN) :: ISUBSH + INTEGER, INTENT(IN) :: IUNPKD + INTEGER, INTENT(IN) :: ISUBSH INTEGER(BYTE), DIMENSION(*), INTENT(INOUT) :: IPACKD !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- ! - IF (ABS(IUNPKD) > 127) THEN - WRITE (ISTDE, *) 'PACK: Argument IUNPKD out of range.' - STOP - ENDIF -! - IF (ISUBSH <= 0) THEN - WRITE (ISTDE, *) 'PACK: ISUBSH=', ISUBSH, ' less than 1' - STOP - ENDIF + IF (ABS(IUNPKD) > 127) THEN + WRITE (ISTDE, *) 'PACK: Argument IUNPKD out of range.' + STOP + ENDIF ! - IPACKD(ISUBSH) = IUNPKD + IF (ISUBSH <= 0) THEN + WRITE (ISTDE, *) 'PACK: ISUBSH=', ISUBSH, ' less than 1' + STOP + ENDIF ! - RETURN - END SUBROUTINE PACK + IPACKD(ISUBSH) = IUNPKD +! + RETURN + END SUBROUTINE PACK diff --git a/src/lib/lib9290/pack_I.f90 b/src/lib/lib9290/pack_I.f90 index 08c7bf1f2..176f7e1fa 100644 --- a/src/lib/lib9290/pack_I.f90 +++ b/src/lib/lib9290/pack_I.f90 @@ -1,15 +1,15 @@ - MODULE pack_I + MODULE pack_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:08 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:08 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE pack (IUNPKD, ISUBSH, IPACKD) - USE vast_kind_param, ONLY: BYTE - INTEGER, INTENT(IN) :: IUNPKD - INTEGER, INTENT(IN) :: ISUBSH - INTEGER(BYTE), DIMENSION(*), INTENT(INOUT) :: IPACKD + SUBROUTINE pack (IUNPKD, ISUBSH, IPACKD) + USE vast_kind_param, ONLY: BYTE + INTEGER, INTENT(IN) :: IUNPKD + INTEGER, INTENT(IN) :: ISUBSH + INTEGER(BYTE), DIMENSION(*), INTENT(INOUT) :: IPACKD !VAST.../IOUNIT/ ISTDE(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/parsjl.f90 b/src/lib/lib9290/parsjl.f90 index fe54aa0d8..9ea220a62 100644 --- a/src/lib/lib9290/parsjl.f90 +++ b/src/lib/lib9290/parsjl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PARSJL(MODE, NCORE, RECORD, LOC, JX, NJX, IERR) + SUBROUTINE PARSJL(MODE, NCORE, RECORD, LOC, JX, NJX, IERR) ! * ! READs and parses a string that specifies angular momentum quan- * ! tum numbers. * @@ -11,26 +11,26 @@ SUBROUTINE PARSJL(MODE, NCORE, RECORD, LOC, JX, NJX, IERR) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:09 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:09 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I USE ORB_C, ONLY: NCF, NW, IQA IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MODE, NCORE, LOC - INTEGER, INTENT(OUT) :: NJX, IERR - CHARACTER(LEN=256), INTENT(IN) :: RECORD + INTEGER, INTENT(IN) :: MODE, NCORE, LOC + INTEGER, INTENT(OUT) :: NJX, IERR + CHARACTER(LEN=256), INTENT(IN) :: RECORD INTEGER, DIMENSION(*), INTENT(OUT) :: JX !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NJXMAX, ISTART, I, ILOOP, IFRAC, IEND, LTEGER, J + INTEGER :: NJXMAX, ISTART, I, ILOOP, IFRAC, IEND, LTEGER, J CHARACTER(LEN=1) :: RECI CHARACTER(LEN=2) :: CTEGER CHARACTER(LEN=6) :: FORM @@ -50,143 +50,143 @@ SUBROUTINE PARSJL(MODE, NCORE, RECORD, LOC, JX, NJX, IERR) ! MODE is 1, the subshell quantum numbers are being read; if MODE ! is 2, the intermediate and final angular momenta are being read ! - IF (MODE == 1) THEN - NJXMAX = 2*(NW - NCORE) - ELSE - NJXMAX = NW - NCORE - ENDIF + IF (MODE == 1) THEN + NJXMAX = 2*(NW - NCORE) + ELSE + NJXMAX = NW - NCORE + ENDIF ! ! Initialise NJX ! - NJX = 0 + NJX = 0 ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - + ISTART = 0 + I = 1 + ! The original algorithm goes through the whole subroutine at least ! once, whatever the value of LOC. Thus we define another integer ! iloop to achieve this. ! XHH 1997.01.28 - - ILOOP = MAX(1,LOC) - DO I = 1, ILOOP - RECI = RECORD(I:I) - IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN - IF (ISTART == 0) THEN - ISTART = I - IFRAC = 0 - ELSE + + ILOOP = MAX(1,LOC) + DO I = 1, ILOOP + RECI = RECORD(I:I) + IF (RECI/=' ' .AND. RECI/=',' .AND. RECI/=';') THEN + IF (ISTART == 0) THEN + ISTART = I + IFRAC = 0 + ELSE IF (RECI == '/') THEN IFRAC = I - ENDIF - ENDIF - ELSE - IF (ISTART /= 0) THEN + ENDIF + ENDIF + ELSE + IF (ISTART /= 0) THEN !XHH~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NJX = NJX + 1 - IF (NJX > NJXMAX) THEN + NJX = NJX + 1 + IF (NJX > NJXMAX) THEN WRITE (6, *) 'PARSJL: Too many angular momentum', & - ' quantum numbers specified;' - IERR = 1 - GO TO 3 - ENDIF - IEND = I - 1 - IF (IFRAC == 0) THEN - CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(ISTART:IEND), FMT=FORM) J - IF (J < 0) THEN + ' quantum numbers specified;' + IERR = 1 + GO TO 3 + ENDIF + IEND = I - 1 + IF (IFRAC == 0) THEN + CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(ISTART:IEND), FMT=FORM) J + IF (J < 0) THEN WRITE (6, *) 'PARSJL: Negative angular momentum', & - ' quantum number found;' - IERR = 2 - GO TO 3 - ENDIF - JX(NJX) = 2*J - ELSE - CALL CONVRT (IEND - IFRAC, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(IFRAC+1:IEND), FMT=FORM) J - IF (J /= 2) THEN + ' quantum number found;' + IERR = 2 + GO TO 3 + ENDIF + JX(NJX) = 2*J + ELSE + CALL CONVRT (IEND - IFRAC, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(IFRAC+1:IEND), FMT=FORM) J + IF (J /= 2) THEN WRITE (6, *) 'PARSJL: The denominator of a', & - ' fractional quantum number must be 2;' - IERR = 3 - GO TO 3 - ENDIF - CALL CONVRT (IFRAC - ISTART, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(ISTART:IFRAC-1), FMT=FORM) J - IF (J < 0) THEN + ' fractional quantum number must be 2;' + IERR = 3 + GO TO 3 + ENDIF + CALL CONVRT (IFRAC - ISTART, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(ISTART:IFRAC-1), FMT=FORM) J + IF (J < 0) THEN WRITE (6, *) 'PARSJL: Negative angular momentum', & - ' quantum number found;' - IERR = 4 - GO TO 3 - ENDIF - JX(NJX) = J - ENDIF - ISTART = 0 + ' quantum number found;' + IERR = 4 + GO TO 3 + ENDIF + JX(NJX) = J + ENDIF + ISTART = 0 !XHH~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ENDIF - ENDIF - END DO -! - IF (LOC >= 1) THEN - + ENDIF + ENDIF + END DO +! + IF (LOC >= 1) THEN + ! The following was accessed one extra time only when 1 <= I = LOC+1 . ! After the do-loop above, the value of I would be either LOC+1 or ! 2, depending on if LOC is greater than 1 or not, respectively - - + + !XHH~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! The following is exactly the same as those above !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NJX = NJX + 1 - IF (NJX > NJXMAX) THEN + NJX = NJX + 1 + IF (NJX > NJXMAX) THEN WRITE (6, *) 'PARSJL: Too many angular momentum', & - ' quantum numbers specified;' - IERR = 1 - GO TO 3 - ENDIF - IEND = I - 1 - IF (IFRAC == 0) THEN - CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(ISTART:IEND), FMT=FORM) J - IF (J < 0) THEN + ' quantum numbers specified;' + IERR = 1 + GO TO 3 + ENDIF + IEND = I - 1 + IF (IFRAC == 0) THEN + CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(ISTART:IEND), FMT=FORM) J + IF (J < 0) THEN WRITE (6, *) 'PARSJL: Negative angular momentum', & - ' quantum number found;' - IERR = 2 - GO TO 3 - ENDIF - JX(NJX) = 2*J - ELSE - CALL CONVRT (IEND - IFRAC, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(IFRAC+1:IEND), FMT=FORM) J - IF (J /= 2) THEN + ' quantum number found;' + IERR = 2 + GO TO 3 + ENDIF + JX(NJX) = 2*J + ELSE + CALL CONVRT (IEND - IFRAC, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(IFRAC+1:IEND), FMT=FORM) J + IF (J /= 2) THEN WRITE (6, *) 'PARSJL: The denominator of a', & - ' fractional quantum number must be 2;' - IERR = 3 - GO TO 3 - ENDIF - CALL CONVRT (IFRAC - ISTART, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(ISTART:IFRAC-1), FMT=FORM) J - IF (J < 0) THEN + ' fractional quantum number must be 2;' + IERR = 3 + GO TO 3 + ENDIF + CALL CONVRT (IFRAC - ISTART, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(ISTART:IFRAC-1), FMT=FORM) J + IF (J < 0) THEN WRITE (6, *) 'PARSJL: Negative angular momentum', & - ' quantum number found;' - IERR = 4 - GO TO 3 - ENDIF - JX(NJX) = J - ENDIF - ISTART = 0 - ENDIF + ' quantum number found;' + IERR = 4 + GO TO 3 + ENDIF + JX(NJX) = J + ENDIF + ISTART = 0 + ENDIF !XHH~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! - IERR = 0 + IERR = 0 ! - 3 CONTINUE - RETURN - END SUBROUTINE PARSJL + 3 CONTINUE + RETURN + END SUBROUTINE PARSJL diff --git a/src/lib/lib9290/parsjl_I.f90 b/src/lib/lib9290/parsjl_I.f90 index bf0e060f1..20c36b43b 100644 --- a/src/lib/lib9290/parsjl_I.f90 +++ b/src/lib/lib9290/parsjl_I.f90 @@ -1,19 +1,19 @@ - MODULE parsjl_I + MODULE parsjl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:09 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:09 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE parsjl (MODE, NCORE, RECORD, LOC, JX, NJX, IERR) - INTEGER, INTENT(IN) :: MODE - INTEGER, INTENT(IN) :: NCORE - CHARACTER (LEN = 256), INTENT(IN) :: RECORD - INTEGER, INTENT(IN) :: LOC - INTEGER, DIMENSION(*), INTENT(OUT) :: JX - INTEGER, INTENT(OUT) :: NJX - INTEGER, INTENT(OUT) :: IERR + SUBROUTINE parsjl (MODE, NCORE, RECORD, LOC, JX, NJX, IERR) + INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: NCORE + CHARACTER (LEN = 256), INTENT(IN) :: RECORD + INTEGER, INTENT(IN) :: LOC + INTEGER, DIMENSION(*), INTENT(OUT) :: JX + INTEGER, INTENT(OUT) :: NJX + INTEGER, INTENT(OUT) :: IERR !VAST.../ORB2/ NW(IN) !VAST...Calls: CONVRT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/posfile.f90 b/src/lib/lib9290/posfile.f90 index 27c2e2984..f1283dbfc 100644 --- a/src/lib/lib9290/posfile.f90 +++ b/src/lib/lib9290/posfile.f90 @@ -1,44 +1,44 @@ !*********************************************************************** - SUBROUTINE POSFILE(MODE, NUNIT, NREC) + SUBROUTINE POSFILE(MODE, NUNIT, NREC) ! Position the file !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:12 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:12 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !---------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: MODE - INTEGER, INTENT(IN) :: NUNIT - INTEGER, INTENT(IN) :: NREC + INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: NUNIT + INTEGER, INTENT(IN) :: NREC !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: FORWD = 0 - INTEGER, PARAMETER :: BACKWD = 1 + INTEGER, PARAMETER :: FORWD = 0 + INTEGER, PARAMETER :: BACKWD = 1 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I + INTEGER :: I !----------------------------------------------- ! - - SELECT CASE (MODE) - - CASE (FORWD) - REWIND (NUNIT) - DO I = 1, NREC - READ (NUNIT) - END DO - - CASE (BACKWD) - DO I = 1, NREC - BACKSPACE (NUNIT) - END DO - - END SELECT - - RETURN - END SUBROUTINE POSFILE + + SELECT CASE (MODE) + + CASE (FORWD) + REWIND (NUNIT) + DO I = 1, NREC + READ (NUNIT) + END DO + + CASE (BACKWD) + DO I = 1, NREC + BACKSPACE (NUNIT) + END DO + + END SELECT + + RETURN + END SUBROUTINE POSFILE diff --git a/src/lib/lib9290/posfile_I.f90 b/src/lib/lib9290/posfile_I.f90 index e0981649d..eb1d54d2c 100644 --- a/src/lib/lib9290/posfile_I.f90 +++ b/src/lib/lib9290/posfile_I.f90 @@ -1,13 +1,13 @@ - MODULE posfile_I + MODULE posfile_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:12 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:12 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE posfile (MODE, NUNIT, NREC) - INTEGER, INTENT(IN) :: MODE - INTEGER, INTENT(IN) :: NUNIT - INTEGER, INTENT(IN) :: NREC + SUBROUTINE posfile (MODE, NUNIT, NREC) + INTEGER, INTENT(IN) :: MODE + INTEGER, INTENT(IN) :: NUNIT + INTEGER, INTENT(IN) :: NREC !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/prsrcn.f90 b/src/lib/lib9290/prsrcn.f90 index d3991bc0e..bc8dea687 100644 --- a/src/lib/lib9290/prsrcn.f90 +++ b/src/lib/lib9290/prsrcn.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRSRCN(RECORD, NCORE, IOCCS, IERR) + SUBROUTINE PRSRCN(RECORD, NCORE, IOCCS, IERR) ! * ! READs and parses a string that specifies a configuration. * ! * @@ -8,120 +8,120 @@ SUBROUTINE PRSRCN(RECORD, NCORE, IOCCS, IERR) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:15 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:15 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW - USE ORB_C + USE ORB_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NCORE - INTEGER, INTENT(OUT) :: IERR - CHARACTER(LEN=256), INTENT(IN) :: RECORD + INTEGER, INTENT(IN) :: NCORE + INTEGER, INTENT(OUT) :: IERR + CHARACTER(LEN=256), INTENT(IN) :: RECORD INTEGER, DIMENSION(NNNW), INTENT(OUT) :: IOCCS !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: I,ISTART,IEND,LENTH,IOS,NPI,J,ISHELL,IOSTRT,IOEND, & - IOCCI,NKJI - CHARACTER(LEN=2) :: SYMI - CHARACTER(LEN=5) :: FORM + IOCCI,NKJI + CHARACTER(LEN=2) :: SYMI + CHARACTER(LEN=5) :: FORM CHARACTER(LEN=1), DIMENSION(3) :: CNUM = (/'1', '2', '3'/) - CHARACTER :: RECI + CHARACTER :: RECI !----------------------------------------------- ! ! Initialise IOCCS for the peel subshells ! - IOCCS(NCORE+1:NW) = 0 + IOCCS(NCORE+1:NW) = 0 ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - 2 CONTINUE - RECI = RECORD(I:I) - IF (RECI == '(') THEN - IEND = I - 1 - 3 CONTINUE - RECI = RECORD(IEND:IEND) - IF (RECI == ' ') THEN - IEND = IEND - 1 - GO TO 3 - ELSE IF (RECI == '-') THEN - READ (RECORD(IEND-1:IEND), '(1A2)') SYMI - IEND = IEND - 2 - ELSE - SYMI(2:2) = ' ' - READ (RECI, '(1A1)') SYMI(1:1) - IEND = IEND - 1 - ENDIF - LENTH = IEND - ISTART + 1 - FORM = '(1I'//CNUM(LENTH)//')' - READ (RECORD(ISTART:IEND), FMT=FORM, IOSTAT=IOS) NPI - IF (IOS /= 0) THEN + ISTART = 0 + I = 1 + 2 CONTINUE + RECI = RECORD(I:I) + IF (RECI == '(') THEN + IEND = I - 1 + 3 CONTINUE + RECI = RECORD(IEND:IEND) + IF (RECI == ' ') THEN + IEND = IEND - 1 + GO TO 3 + ELSE IF (RECI == '-') THEN + READ (RECORD(IEND-1:IEND), '(1A2)') SYMI + IEND = IEND - 2 + ELSE + SYMI(2:2) = ' ' + READ (RECI, '(1A1)') SYMI(1:1) + IEND = IEND - 1 + ENDIF + LENTH = IEND - ISTART + 1 + FORM = '(1I'//CNUM(LENTH)//')' + READ (RECORD(ISTART:IEND), FMT=FORM, IOSTAT=IOS) NPI + IF (IOS /= 0) THEN WRITE (6, *) 'PRSRCN: Principal quantum number ', RECORD(ISTART:& - IEND) - WRITE (6, *) ' could not be decoded.' - IERR = 1 - GO TO 6 - ENDIF - DO J = NCORE + 1, NW - IF (NP(J)/=NPI .OR. NH(J)/=SYMI) CYCLE - ISHELL = J - GO TO 5 - END DO - WRITE (6, *) 'PRSRCL: Not a peel subshell.' - IERR = 2 - GO TO 6 - 5 CONTINUE - IOSTRT = I + 1 - ELSE IF (RECI == ')') THEN - IOEND = I - 1 - LENTH = IOEND - IOSTRT + 1 - FORM = '(1I'//CNUM(LENTH)//')' - READ (RECORD(IOSTRT:IOEND), FMT=FORM, IOSTAT=IOS) IOCCI - IF (IOS /= 0) THEN - WRITE (6, *) 'PRSRCN: Occupation number ', RECORD(IOSTRT:IOEND) - WRITE (6, *) ' could not be decoded.' - IERR = 3 - GO TO 6 - ENDIF - NKJI = NKJ(ISHELL) - IF (NKJI <= 7) THEN - IF (IOCCI<0 .OR. IOCCI>NKJ(ISHELL)+1) THEN - WRITE (6, *) 'PRSRCN: Occupation specified' - WRITE (6, *) ' incorrectly for ', NP(ISHELL), NH(ISHELL) - WRITE (6, *) ' subshell.' - IERR = 4 - GO TO 6 - ENDIF - ELSE - IF (IOCCI<0 .OR. IOCCI>2) THEN - WRITE (6, *) 'PRSRCN: Occupation specified' - WRITE (6, *) ' incorrectly for ', NP(ISHELL), NH(ISHELL) - WRITE (6, *) ' subshell.' - IERR = 5 - GO TO 6 - ENDIF - ENDIF - IOCCS(ISHELL) = IOCCI - ISTART = 0 - ELSE - IF (ISTART == 0) ISTART = I - ENDIF + IEND) + WRITE (6, *) ' could not be decoded.' + IERR = 1 + GO TO 6 + ENDIF + DO J = NCORE + 1, NW + IF (NP(J)/=NPI .OR. NH(J)/=SYMI) CYCLE + ISHELL = J + GO TO 5 + END DO + WRITE (6, *) 'PRSRCL: Not a peel subshell.' + IERR = 2 + GO TO 6 + 5 CONTINUE + IOSTRT = I + 1 + ELSE IF (RECI == ')') THEN + IOEND = I - 1 + LENTH = IOEND - IOSTRT + 1 + FORM = '(1I'//CNUM(LENTH)//')' + READ (RECORD(IOSTRT:IOEND), FMT=FORM, IOSTAT=IOS) IOCCI + IF (IOS /= 0) THEN + WRITE (6, *) 'PRSRCN: Occupation number ', RECORD(IOSTRT:IOEND) + WRITE (6, *) ' could not be decoded.' + IERR = 3 + GO TO 6 + ENDIF + NKJI = NKJ(ISHELL) + IF (NKJI <= 7) THEN + IF (IOCCI<0 .OR. IOCCI>NKJ(ISHELL)+1) THEN + WRITE (6, *) 'PRSRCN: Occupation specified' + WRITE (6, *) ' incorrectly for ', NP(ISHELL), NH(ISHELL) + WRITE (6, *) ' subshell.' + IERR = 4 + GO TO 6 + ENDIF + ELSE + IF (IOCCI<0 .OR. IOCCI>2) THEN + WRITE (6, *) 'PRSRCN: Occupation specified' + WRITE (6, *) ' incorrectly for ', NP(ISHELL), NH(ISHELL) + WRITE (6, *) ' subshell.' + IERR = 5 + GO TO 6 + ENDIF + ENDIF + IOCCS(ISHELL) = IOCCI + ISTART = 0 + ELSE + IF (ISTART == 0) ISTART = I + ENDIF ! - IF (I < 256) THEN - I = I + 1 - GO TO 2 - ENDIF + IF (I < 256) THEN + I = I + 1 + GO TO 2 + ENDIF ! - IERR = 0 + IERR = 0 ! - 6 CONTINUE - RETURN - END SUBROUTINE PRSRCN + 6 CONTINUE + RETURN + END SUBROUTINE PRSRCN diff --git a/src/lib/lib9290/prsrcn_I.f90 b/src/lib/lib9290/prsrcn_I.f90 index c6f9f6a36..bec863f08 100644 --- a/src/lib/lib9290/prsrcn_I.f90 +++ b/src/lib/lib9290/prsrcn_I.f90 @@ -1,19 +1,19 @@ - MODULE prsrcn_I + MODULE prsrcn_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:15 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:15 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prsrcn (RECORD, NCORE, IOCCS, IERR) + SUBROUTINE prsrcn (RECORD, NCORE, IOCCS, IERR) USE parameter_def, ONLY: NNNW - CHARACTER (LEN = 256), INTENT(IN) :: RECORD - INTEGER, INTENT(IN) :: NCORE - INTEGER, DIMENSION(NNNW), INTENT(OUT) :: IOCCS - INTEGER, INTENT(OUT) :: IERR + CHARACTER (LEN = 256), INTENT(IN) :: RECORD + INTEGER, INTENT(IN) :: NCORE + INTEGER, DIMENSION(NNNW), INTENT(OUT) :: IOCCS + INTEGER, INTENT(OUT) :: IERR !VAST.../ORB2/ NW(IN) !VAST.../ORB4/ NP(IN) !VAST.../ORB5/ NKJ(IN) !VAST.../ORB10/ NH(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/prsrsl.f90 b/src/lib/lib9290/prsrsl.f90 index fa8a5fe93..ed38b44b4 100644 --- a/src/lib/lib9290/prsrsl.f90 +++ b/src/lib/lib9290/prsrsl.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE PRSRSL(NFILE, ID) + SUBROUTINE PRSRSL(NFILE, ID) ! * ! READs and parses a list of subshell labels on unit NFILE to load * ! COMMON blocks /ORB4/, /ORB5/, and /ORB10/; the value of NW in * @@ -13,134 +13,134 @@ SUBROUTINE PRSRSL(NFILE, ID) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:16 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:16 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE parameter_def, ONLY: NNNW - USE IOUNIT_C - USE ORB_C + USE IOUNIT_C + USE ORB_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE convrt_I + USE convrt_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: NFILE - INTEGER , INTENT(IN) :: ID + INTEGER , INTENT(IN) :: NFILE + INTEGER , INTENT(IN) :: ID !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ISTART, I, IEND, IOS, II, IIB2, LTEGER - LOGICAL :: NEWREC + INTEGER :: ISTART, I, IEND, IOS, II, IIB2, LTEGER + LOGICAL :: NEWREC CHARACTER(LEN=1) :: RECI - CHARACTER(LEN=2) :: CTEGER, SYM - CHARACTER(LEN=6) :: FORM -! CHARACTER(LEN=500) :: RECORD, RECORD2 - CHARACTER(LEN=1000) :: RECORD, RECORD2 - CHARACTER(LEN=2), DIMENSION(19) :: SYMLST + CHARACTER(LEN=2) :: CTEGER, SYM + CHARACTER(LEN=6) :: FORM +! CHARACTER(LEN=500) :: RECORD, RECORD2 + CHARACTER(LEN=1000) :: RECORD, RECORD2 + CHARACTER(LEN=2), DIMENSION(19) :: SYMLST ! DATA SYMLST/ 's ', 'p-', 'p ', 'd-', 'd ', 'f-', 'f ', 'g-', 'g ', 'h-', & - 'h ', 'i-', 'i ', 'k-', 'k ', 'l-', 'l ', 'm-', 'm'/ + 'h ', 'i-', 'i ', 'k-', 'k ', 'l-', 'l ', 'm-', 'm'/ !----------------------------------------------- IOS = 0 ! ! Read the records ! - NEWREC = .FALSE. - READ (NFILE, '(A)') RECORD - IF (ID == 2) THEN - READ (NFILE, '(A)') RECORD2 - IF (RECORD2(1:3) == 'CSF') THEN - BACKSPACE (UNIT=NFILE) - ELSE - NEWREC = .TRUE. - ENDIF - ENDIF + NEWREC = .FALSE. + READ (NFILE, '(A)') RECORD + IF (ID == 2) THEN + READ (NFILE, '(A)') RECORD2 + IF (RECORD2(1:3) == 'CSF') THEN + BACKSPACE (UNIT=NFILE) + ELSE + NEWREC = .TRUE. + ENDIF + ENDIF ! ! Parse RECORD from left to right ! - ISTART = 0 - I = 1 - 1 CONTINUE - RECI = RECORD(I:I) - IF (RECI/=' ' .AND. RECI/=',') THEN - IF (ISTART == 0) ISTART = I - ELSE - IF (ISTART /= 0) THEN - IEND = I - 1 - RECI = RECORD(IEND:IEND) - IF (RECI == '-') THEN + ISTART = 0 + I = 1 + 1 CONTINUE + RECI = RECORD(I:I) + IF (RECI/=' ' .AND. RECI/=',') THEN + IF (ISTART == 0) ISTART = I + ELSE + IF (ISTART /= 0) THEN + IEND = I - 1 + RECI = RECORD(IEND:IEND) + IF (RECI == '-') THEN ! READ (RECORD(IEND-1:IEND),'(1A2)',IOSTAT = IOS) SYM - SYM = RECORD(IEND-1:IEND) - IF (IOS /= 0) THEN + SYM = RECORD(IEND-1:IEND) + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'PRSRSL: Symmetry ', RECORD(IEND-1:IEND), & - ' could not be decoded.' - STOP - ENDIF - IEND = IEND - 2 - ELSE - SYM(2:2) = ' ' + ' could not be decoded.' + STOP + ENDIF + IEND = IEND - 2 + ELSE + SYM(2:2) = ' ' ! READ (RECI,'(1A1)',IOSTAT = IOS) SYM(1:1) - SYM(1:1) = RECI - IF (IOS /= 0) THEN + SYM(1:1) = RECI + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'PRSRSL: Symmetry ', RECI, ' could not', & - ' be decoded.' - STOP - ENDIF - IEND = IEND - 1 - ENDIF - DO II = 1, 19 - IF (SYM /= SYMLST(II)) CYCLE - NW = NW + 1 - IF (NW > NNNW) THEN + ' be decoded.' + STOP + ENDIF + IEND = IEND - 1 + ENDIF + DO II = 1, 19 + IF (SYM /= SYMLST(II)) CYCLE + NW = NW + 1 + IF (NW > NNNW) THEN WRITE (ISTDE, *) 'PRSRSL: Number of subshells ', & - 'exceeds allocation: plant NW was set to', NNNW - STOP - ENDIF - NH(NW) = SYM - IIB2 = II/2 - NKL(NW) = IIB2 - IF (MOD(II,2) == 1) THEN - NAK(NW) = (-IIB2) - 1 - NKJ(NW) = II - ELSE - NAK(NW) = IIB2 - NKJ(NW) = II - 1 - ENDIF - CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) - FORM = '(1I'//CTEGER(1:LTEGER)//')' - READ (RECORD(ISTART:IEND), FMT=FORM, IOSTAT=IOS) NP(NW) - IF (IOS /= 0) THEN + 'exceeds allocation: plant NW was set to', NNNW + STOP + ENDIF + NH(NW) = SYM + IIB2 = II/2 + NKL(NW) = IIB2 + IF (MOD(II,2) == 1) THEN + NAK(NW) = (-IIB2) - 1 + NKJ(NW) = II + ELSE + NAK(NW) = IIB2 + NKJ(NW) = II - 1 + ENDIF + CALL CONVRT (IEND - ISTART + 1, CTEGER, LTEGER) + FORM = '(1I'//CTEGER(1:LTEGER)//')' + READ (RECORD(ISTART:IEND), FMT=FORM, IOSTAT=IOS) NP(NW) + IF (IOS /= 0) THEN WRITE (ISTDE, *) 'PRSRSL: Principal quantum number ', RECORD(& - ISTART:IEND), ' could not be decoded.' - STOP - ENDIF - GO TO 3 - END DO - WRITE (ISTDE, *) 'PRSRSL: Symmetry ', SYM, ' could not be decoded.' - STOP - 3 CONTINUE - ISTART = 0 - ENDIF - ENDIF + ISTART:IEND), ' could not be decoded.' + STOP + ENDIF + GO TO 3 + END DO + WRITE (ISTDE, *) 'PRSRSL: Symmetry ', SYM, ' could not be decoded.' + STOP + 3 CONTINUE + ISTART = 0 + ENDIF + ENDIF ! -! IF (I < 500) THEN - IF (I < 1000) THEN - I = I + 1 - GO TO 1 - ENDIF - IF (NEWREC) THEN - RECORD = RECORD2 - NEWREC = .FALSE. - I = 1 - ISTART = 0 - GO TO 1 - ENDIF +! IF (I < 500) THEN + IF (I < 1000) THEN + I = I + 1 + GO TO 1 + ENDIF + IF (NEWREC) THEN + RECORD = RECORD2 + NEWREC = .FALSE. + I = 1 + ISTART = 0 + GO TO 1 + ENDIF ! - RETURN - END SUBROUTINE PRSRSL + RETURN + END SUBROUTINE PRSRSL diff --git a/src/lib/lib9290/prsrsl_I.f90 b/src/lib/lib9290/prsrsl_I.f90 index e5c3d1adf..d7c7e61ee 100644 --- a/src/lib/lib9290/prsrsl_I.f90 +++ b/src/lib/lib9290/prsrsl_I.f90 @@ -1,11 +1,11 @@ - MODULE prsrsl_I + MODULE prsrsl_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:16 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:16 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE prsrsl (NFILE, ID) - INTEGER, INTENT(IN) :: NFILE - INTEGER, INTENT(IN) :: ID + SUBROUTINE prsrsl (NFILE, ID) + INTEGER, INTENT(IN) :: NFILE + INTEGER, INTENT(IN) :: ID !VAST.../IOUNIT/ ISTDE(IN) !VAST.../ORB2/ NW(INOUT) !VAST.../ORB4/ NP(INOUT), NAK(OUT) @@ -13,6 +13,6 @@ SUBROUTINE prsrsl (NFILE, ID) !VAST.../ORB10/ NH(OUT) !VAST...Calls: CONVRT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/quad.f90 b/src/lib/lib9290/quad.f90 index ba226ccc2..1f12fc9cc 100644 --- a/src/lib/lib9290/quad.f90 +++ b/src/lib/lib9290/quad.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE QUAD(RESULT) + SUBROUTINE QUAD(RESULT) ! * ! The argument result is an approximation to the integral of F(R) * ! from zero to infinity, where the values of RP(I)*F(R(I)) are * @@ -23,68 +23,68 @@ SUBROUTINE QUAD(RESULT) ! Written by Farid A Parpia, at Oxford Last updated: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:18 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:18 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEF_C - USE GRID_C - USE NCC_C + USE vast_kind_param, ONLY: DOUBLE + USE DEF_C + USE GRID_C + USE NCC_C USE TATB_C, ONLY: TA, MTP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - REAL(DOUBLE) , INTENT(OUT) :: RESULT + REAL(DOUBLE) , INTENT(OUT) :: RESULT !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MTPM1, I, IP1, LOC - REAL(DOUBLE) :: TAI, TAIP1, QUOTT, FRIP1, FRI, RATIO, RIP1, RI, SIGMA + INTEGER :: MTPM1, I, IP1, LOC + REAL(DOUBLE) :: TAI, TAIP1, QUOTT, FRIP1, FRI, RATIO, RIP1, RI, SIGMA !----------------------------------------------- ! ! ! Find first values that will permit computation of exponent ! - MTPM1 = MTP - 1 - DO I = 2, MTPM1 + MTPM1 = MTP - 1 + DO I = 2, MTPM1 ! - TAI = TA(I) - IF (ABS(TAI) <= 0.D0) CYCLE + TAI = TA(I) + IF (ABS(TAI) <= 0.D0) CYCLE ! - IP1 = I + 1 - TAIP1 = TA(IP1) - QUOTT = TAIP1/TAI + IP1 = I + 1 + TAIP1 = TA(IP1) + QUOTT = TAIP1/TAI ! - IF (QUOTT <= 0.D0) CYCLE + IF (QUOTT <= 0.D0) CYCLE ! ! Exponent from fit ! - FRIP1 = TAIP1/RP(IP1) - FRI = TAI/RP(I) - RATIO = FRIP1/FRI - RIP1 = R(IP1) - RI = R(I) - SIGMA = LOG(RATIO)/LOG(RIP1/RI) + FRIP1 = TAIP1/RP(IP1) + FRI = TAI/RP(I) + RATIO = FRIP1/FRI + RIP1 = R(IP1) + RI = R(I) + SIGMA = LOG(RATIO)/LOG(RIP1/RI) ! ! Analytical integration and error estimate for interval r(1:i) ! - FRI = RI*FRI - RESULT = FRI/(SIGMA + 1.D0) + FRI = RI*FRI + RESULT = FRI/(SIGMA + 1.D0) ! ! Set the tail to zero ! - TA(MTP+1:3+MTP) = 0.D0 + TA(MTP+1:3+MTP) = 0.D0 ! ! Newton-Cotes quadature for the remainder ! - RESULT = RESULT + C1*TAI + RESULT = RESULT + C1*TAI RESULT = RESULT + SUM(C2*(TA(IP1:MTP:4)+TA(IP1+2:MTP+2:4))+C3*TA(IP1+1& - :MTP+1:4)+C4*TA(IP1+3:MTP+3:4)) - IF (MOD(MTP - I,4) == 0) RESULT = RESULT - C1*TA(MTP) + :MTP+1:4)+C4*TA(IP1+3:MTP+3:4)) + IF (MOD(MTP - I,4) == 0) RESULT = RESULT - C1*TA(MTP) ! ! Test of result's accuracy; `decomment' to activate ! @@ -92,19 +92,19 @@ SUBROUTINE QUAD(RESULT) ! RATIO = ABS (ESTDER/RESULT) ! IF (RATIO .GT. ACCY) PRINT (*,300) RATIO ! - GO TO 4 + GO TO 4 ! - END DO + END DO ! ! No value which will permit computation of exponent ! - RESULT = 0.D0 + RESULT = 0.D0 ! - 4 CONTINUE - RETURN + 4 CONTINUE + RETURN ! 300 FORMAT(/,'QUAD: Estimated accuracy is ',1P,D10.3,/,& - ' Decrease RNT or improve input data conditioning to',' ameliorate.'/) - RETURN + ' Decrease RNT or improve input data conditioning to',' ameliorate.'/) + RETURN ! - END SUBROUTINE QUAD + END SUBROUTINE QUAD diff --git a/src/lib/lib9290/quad_I.f90 b/src/lib/lib9290/quad_I.f90 index 5e1d325fc..00c85d95e 100644 --- a/src/lib/lib9290/quad_I.f90 +++ b/src/lib/lib9290/quad_I.f90 @@ -1,14 +1,14 @@ - MODULE quad_I + MODULE quad_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:18 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:18 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE quad (RESULT) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), INTENT(OUT) :: RESULT + SUBROUTINE quad (RESULT) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), INTENT(OUT) :: RESULT !VAST.../GRID/ R(IN), RP(IN) !VAST.../NCC/ C1(IN), C2(IN), C3(IN), C4(IN) !VAST.../TATB/ TA(INOUT), MTP(IN) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/radgrd.f90 b/src/lib/lib9290/radgrd.f90 index ec15051fc..9daa7301f 100644 --- a/src/lib/lib9290/radgrd.f90 +++ b/src/lib/lib9290/radgrd.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE RADGRD + SUBROUTINE RADGRD ! * ! This routine sets up the radial grid R and the associated arr- * ! ays RP and RPOR in the COMMON block /GRID/. Different grids * @@ -9,126 +9,126 @@ SUBROUTINE RADGRD ! Written by Farid A Parpia, at Oxford Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:19 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:19 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE DEF_C, ONLY: PRECIS - USE GRID_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE DEF_C, ONLY: PRECIS + USE GRID_C IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NP10, I, NB2, NROWS, II, II1, II2 + INTEGER :: NP10, I, NB2, NROWS, II, II1, II2 REAL(DOUBLE) :: EPH, ETT, ETTM1, EPSLON, A, RLAST, REST, T, RESTS, FOFR, & - FPRI, DELR + FPRI, DELR !----------------------------------------------- ! ! ! RPOR(1) is never used in the program: it is arbitrarily ! set to zero ! - NP10 = N + 10 - R(1) = 0.0D00 - RPOR(1) = 0.0D00 + NP10 = N + 10 + R(1) = 0.0D00 + RPOR(1) = 0.0D00 ! ! Now set up the grids ! - IF (HP == 0.0D00) THEN + IF (HP == 0.0D00) THEN ! default comes here ! ! Exponential grid if HP is zero ! ! Initializations ! - RP(1) = RNT - EPH = EXP(H) - ETT = 1.0D00 + RP(1) = RNT + EPH = EXP(H) + ETT = 1.0D00 ! ! Set up the arrays R, RP, RPOR ! - DO I = 2, NP10 - ETT = EPH*ETT - ETTM1 = ETT - 1.0D00 - R(I) = RNT*ETTM1 - RP(I) = RNT*ETT - RPOR(I) = ETT/ETTM1 - END DO + DO I = 2, NP10 + ETT = EPH*ETT + ETTM1 = ETT - 1.0D00 + R(I) = RNT*ETTM1 + RP(I) = RNT*ETT + RPOR(I) = ETT/ETTM1 + END DO ! - ELSE + ELSE ! ! Asymptotically-linear exponential grid otherwise: ! ! Initializations ! - EPSLON = 1.0D03*PRECIS - A = H/HP - RP(1) = RNT/(A*RNT + 1.0D00) - RLAST = 0.0D00 - REST = 0.0D00 + EPSLON = 1.0D03*PRECIS + A = H/HP + RP(1) = RNT/(A*RNT + 1.0D00) + RLAST = 0.0D00 + REST = 0.0D00 ! ! Set up the arrays R, RP, RPOR ! - DO I = 2, NP10 + DO I = 2, NP10 ! - T = H*DBLE(I - 1) + T = H*DBLE(I - 1) ! ! Solve the implicit equation for R using the Newton-Raphson ! method ! - 2 CONTINUE - RESTS = REST + RNT - FOFR = LOG(RESTS/RNT) + A*REST - T - FPRI = RESTS/(A*RESTS + 1.0D00) - DELR = -FOFR*FPRI - REST = RLAST + DELR + 2 CONTINUE + RESTS = REST + RNT + FOFR = LOG(RESTS/RNT) + A*REST - T + FPRI = RESTS/(A*RESTS + 1.0D00) + DELR = -FOFR*FPRI + REST = RLAST + DELR ! - IF (ABS(DELR/REST) < EPSLON) THEN - R(I) = REST - RESTS = REST + RNT - FPRI = RESTS/(A*RESTS + 1.0D00) - RP(I) = FPRI - RPOR(I) = FPRI/REST - ELSE - RLAST = REST - GO TO 2 - ENDIF + IF (ABS(DELR/REST) < EPSLON) THEN + R(I) = REST + RESTS = REST + RNT + FPRI = RESTS/(A*RESTS + 1.0D00) + RP(I) = FPRI + RPOR(I) = FPRI/REST + ELSE + RLAST = REST + GO TO 2 + ENDIF ! - END DO + END DO ! - ENDIF + ENDIF ! ! Debug printout ! - IF (LDBPR(1)) THEN - WRITE (99, 300) - NB2 = N/2 - IF (2*NB2 == N) THEN - NROWS = NB2 - ELSE - NROWS = NB2 + 1 - ENDIF - DO II = 1, NROWS - II1 = II - II2 = II1 + NROWS - IF (II2 <= N) THEN + IF (LDBPR(1)) THEN + WRITE (99, 300) + NB2 = N/2 + IF (2*NB2 == N) THEN + NROWS = NB2 + ELSE + NROWS = NB2 + 1 + ENDIF + DO II = 1, NROWS + II1 = II + II2 = II1 + NROWS + IF (II2 <= N) THEN WRITE (99, 301) R(II1), RP(II1), RPOR(II1), R(II2), RP(II2), & - RPOR(II2) - ELSE IF (II1 <= N) THEN - WRITE (99, 301) R(II1), RP(II1), RPOR(II1) - ENDIF - END DO - ENDIF + RPOR(II2) + ELSE IF (II1 <= N) THEN + WRITE (99, 301) R(II1), RP(II1), RPOR(II1) + ENDIF + END DO + ENDIF ! - RETURN + RETURN ! 300 FORMAT(/,'From SUBROUTINE RADGRD:'/,2(& - ' -------- r -------- -------- r'' -------',' ------- r''/r ------')) - 301 FORMAT(1P,6(1X,1D19.12)) - RETURN + ' -------- r -------- -------- r'' -------',' ------- r''/r ------')) + 301 FORMAT(1P,6(1X,1D19.12)) + RETURN ! - END SUBROUTINE RADGRD + END SUBROUTINE RADGRD diff --git a/src/lib/lib9290/radgrd_I.f90 b/src/lib/lib9290/radgrd_I.f90 index 346c8c8e3..5fe743ad0 100644 --- a/src/lib/lib9290/radgrd_I.f90 +++ b/src/lib/lib9290/radgrd_I.f90 @@ -1,14 +1,14 @@ - MODULE radgrd_I + MODULE radgrd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:19 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:19 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE radgrd + SUBROUTINE radgrd !VAST.../DEBUGR/ LDBPR(IN) !VAST.../DEF0/ PRECIS(IN) !VAST.../GRID/ R(INOUT), RP(INOUT), RPOR(INOUT), RNT(IN) !VAST.../GRID/ H(IN), HP(IN), N(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/rint.f90 b/src/lib/lib9290/rint.f90 index 6bad4887c..3db9caf7e 100644 --- a/src/lib/lib9290/rint.f90 +++ b/src/lib/lib9290/rint.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINT (I, J, K) + REAL(KIND(0.0D0)) FUNCTION RINT (I, J, K) ! * ! The value of RINT is an approximation to: * ! * @@ -16,20 +16,20 @@ REAL(KIND(0.0D0)) FUNCTION RINT (I, J, K) ! Written by Farid A Parpia, at Oxford Last updated: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE GRID_C + USE vast_kind_param, ONLY: DOUBLE + USE GRID_C USE TATB_C, ONLY: TA, MTP - USE WAVE_C + USE WAVE_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE quad_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -37,34 +37,34 @@ REAL(KIND(0.0D0)) FUNCTION RINT (I, J, K) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: I - INTEGER :: J - INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J + INTEGER, INTENT(IN) :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: L - REAL(DOUBLE) :: RESULT + INTEGER :: L + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! ! Determine the maximum tabulation point for the integrand ! - MTP = MIN(MF(I),MF(J)) + MTP = MIN(MF(I),MF(J)) ! ! Tabulate the integrand as required for SUBROUTINE QUAD; the ! value at the first tabulation point is arbitrary ! - TA(1) = 0.0D00 - DO L = 2, MTP - TA(L) = R(L)**K*(PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))*RP(L) - END DO + TA(1) = 0.0D00 + DO L = 2, MTP + TA(L) = R(L)**K*(PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))*RP(L) + END DO ! ! Perform the quadrature ! - CALL QUAD (RESULT) - RINT = RESULT + CALL QUAD (RESULT) + RINT = RESULT ! - RETURN + RETURN ! - END FUNCTION RINT + END FUNCTION RINT diff --git a/src/lib/lib9290/rint_I.f90 b/src/lib/lib9290/rint_I.f90 index 1bb7bf95f..9856321c2 100644 --- a/src/lib/lib9290/rint_I.f90 +++ b/src/lib/lib9290/rint_I.f90 @@ -1,12 +1,12 @@ - MODULE rint_I + MODULE rint_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:22 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:22 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rint (I, J, K) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - END FUNCTION - END INTERFACE - END MODULE + REAL(KIND(0.0D0)) FUNCTION rint (I, J, K) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/rinti.f90 b/src/lib/lib9290/rinti.f90 index 28bdc3047..7f4c757ef 100644 --- a/src/lib/lib9290/rinti.f90 +++ b/src/lib/lib9290/rinti.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION RINTI (J, K, MODE) + REAL(KIND(0.0D0)) FUNCTION RINTI (J, K, MODE) ! * ! The value of this function is the one-electron integral I (J,K) * ! for orbitals J, K. The analytical expression for this quantity * @@ -12,25 +12,25 @@ REAL(KIND(0.0D0)) FUNCTION RINTI (J, K, MODE) ! Written by Farid A Parpia, at Oxford Last revision: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:23 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:23 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE DEBUG_C - USE DEF_C, ONLY: C - USE GRID_C - USE NPOT_C, ONLY: ZZ - USE ORB_C + USE DEF_C, ONLY: C + USE GRID_C + USE NPOT_C, ONLY: ZZ + USE ORB_C USE TATB_C, ONLY: TA, TB, MTP - USE WAVE_C, ONLY: MF,PF,QF + USE WAVE_C, ONLY: MF,PF,QF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dpbdt_I - USE quad_I + USE dpbdt_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -38,82 +38,82 @@ REAL(KIND(0.0D0)) FUNCTION RINTI (J, K, MODE) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: J - INTEGER :: K - INTEGER, INTENT(IN) :: MODE + INTEGER :: J + INTEGER :: K + INTEGER, INTENT(IN) :: MODE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4 + INTEGER :: I + REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4 !----------------------------------------------- ! ! Stop if orbitals J and K have different kappa values ! - IF (NAK(J) /= NAK(K)) THEN - WRITE (*, 300) NP(J), NH(J), NP(K), NH(K) - STOP - ENDIF + IF (NAK(J) /= NAK(K)) THEN + WRITE (*, 300) NP(J), NH(J), NP(K), NH(K) + STOP + ENDIF ! - MTP = MAX(MF(J),MF(K)) + MTP = MAX(MF(J),MF(K)) ! ! Kinetic energy contribution ! ! Piece involving derivatives ! - CALL DPBDT (K) - TA(1) = 0.D0 - DO I = 2, MTP - TA(I) = QF(I,J)*TA(I) - PF(I,J)*TB(I) - END DO - CALL QUAD (PIECE1) - PIECE1 = C*PIECE1/H + CALL DPBDT (K) + TA(1) = 0.D0 + DO I = 2, MTP + TA(I) = QF(I,J)*TA(I) - PF(I,J)*TB(I) + END DO + CALL QUAD (PIECE1) + PIECE1 = C*PIECE1/H ! ! Pieces not involving derivatives ! - TA(1) = 0.D0 - DO I = 2, MTP - TA(I) = RP(I)*QF(I,J)*QF(I,K) - END DO - CALL QUAD (PIECE2) - PIECE2 = -2.D0*C*C*PIECE2 + TA(1) = 0.D0 + DO I = 2, MTP + TA(I) = RP(I)*QF(I,J)*QF(I,K) + END DO + CALL QUAD (PIECE2) + PIECE2 = -2.D0*C*C*PIECE2 ! - TA(1) = 0.D0 - DO I = 2, MTP - TA(I) = RPOR(I)*(PF(I,J)*QF(I,K) + QF(I,J)*PF(I,K)) - END DO - CALL QUAD (PIECE3) - PIECE3 = PIECE3*C*DBLE(NAK(K)) + TA(1) = 0.D0 + DO I = 2, MTP + TA(I) = RPOR(I)*(PF(I,J)*QF(I,K) + QF(I,J)*PF(I,K)) + END DO + CALL QUAD (PIECE3) + PIECE3 = PIECE3*C*DBLE(NAK(K)) ! ! Contribution from nuclear potential only if MODE is 0 ! - IF (MODE == 0) THEN + IF (MODE == 0) THEN ! - TA(1) = 0.D0 - DO I = 2, MTP - TA(I) = RPOR(I)*ZZ(I)*(PF(I,J)*PF(I,K) + QF(I,J)*QF(I,K)) - END DO - CALL QUAD (PIECE4) - PIECE4 = -PIECE4 + TA(1) = 0.D0 + DO I = 2, MTP + TA(I) = RPOR(I)*ZZ(I)*(PF(I,J)*PF(I,K) + QF(I,J)*QF(I,K)) + END DO + CALL QUAD (PIECE4) + PIECE4 = -PIECE4 ! - ELSE - PIECE4 = 0.D0 - ENDIF + ELSE + PIECE4 = 0.D0 + ENDIF ! - RINTI = PIECE1 + PIECE2 + PIECE3 + PIECE4 + RINTI = PIECE1 + PIECE2 + PIECE3 + PIECE4 ! ! Debug printout ! IF (MODE==0 .AND. LDBPR(4)) WRITE (99, 301) NP(J), NH(J), NP(K), NH(K), & - RINTI + RINTI IF (MODE/=0 .AND. LDBPR(5)) WRITE (99, 302) NP(J), NH(J), NP(K), NH(K), & - RINTI + RINTI ! - RETURN + RETURN ! - 300 FORMAT('RINTI: Attempt to calculate I(',1I2,1A2,',',1I2,1A2,')') - 301 FORMAT(/,' I (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/) - 302 FORMAT(/,' K (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/) - RETURN + 300 FORMAT('RINTI: Attempt to calculate I(',1I2,1A2,',',1I2,1A2,')') + 301 FORMAT(/,' I (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/) + 302 FORMAT(/,' K (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/) + RETURN ! - END FUNCTION RINTI + END FUNCTION RINTI diff --git a/src/lib/lib9290/rinti_I.f90 b/src/lib/lib9290/rinti_I.f90 index 535d8ba62..c89b3a78a 100644 --- a/src/lib/lib9290/rinti_I.f90 +++ b/src/lib/lib9290/rinti_I.f90 @@ -1,12 +1,12 @@ - MODULE rinti_I + MODULE rinti_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:23 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:23 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION rinti (J, K, MODE) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: MODE + REAL(KIND(0.0D0)) FUNCTION rinti (J, K, MODE) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: MODE !VAST.../DEBUGR/ LDBPR(IN) !VAST.../DEF2/ C(IN) !VAST.../GRID/ RP(IN), RPOR(IN), H(IN) @@ -17,6 +17,6 @@ REAL(KIND(0.0D0)) FUNCTION rinti (J, K, MODE) !VAST.../WAVE/ MF(IN) !VAST...Calls: DPBDT, QF, PF, QUAD !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setcon.f90 b/src/lib/lib9290/setcon.f90 index 6fcaf6874..4b48e4274 100644 --- a/src/lib/lib9290/setcon.f90 +++ b/src/lib/lib9290/setcon.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCON + SUBROUTINE SETCON ! * ! This subprogram sets the values of the fundamental and derived * ! physical constants, and other useful constants. * @@ -8,29 +8,29 @@ SUBROUTINE SETCON ! Written by Farid A Parpia, at Oxford Last updated: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:28 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:28 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE DEF_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE DEF_C IMPLICIT NONE !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - REAL(DOUBLE), PARAMETER :: AINFCM = 0.52917721067D-08 - REAL(DOUBLE), PARAMETER :: ALFAI = 137.035999139D00 - REAL(DOUBLE), PARAMETER :: CCMPS = 2.99792458D10 - REAL(DOUBLE), PARAMETER :: EESU = 4.803204673D-10 - REAL(DOUBLE), PARAMETER :: EMEG = 9.10938356D-28 - REAL(DOUBLE), PARAMETER :: EMEAMU = 5.48579909070D-04 - REAL(DOUBLE), PARAMETER :: EMPAMU = 1.007276466879D00 - REAL(DOUBLE), PARAMETER :: HBARES = 1.054571800D-27 - REAL(DOUBLE), PARAMETER :: RINFEV = 13.605693009D00 - REAL(DOUBLE), PARAMETER :: RINFK = 109737.31568508D00 + REAL(DOUBLE), PARAMETER :: AINFCM = 0.52917721067D-08 + REAL(DOUBLE), PARAMETER :: ALFAI = 137.035999139D00 + REAL(DOUBLE), PARAMETER :: CCMPS = 2.99792458D10 + REAL(DOUBLE), PARAMETER :: EESU = 4.803204673D-10 + REAL(DOUBLE), PARAMETER :: EMEG = 9.10938356D-28 + REAL(DOUBLE), PARAMETER :: EMEAMU = 5.48579909070D-04 + REAL(DOUBLE), PARAMETER :: EMPAMU = 1.007276466879D00 + REAL(DOUBLE), PARAMETER :: HBARES = 1.054571800D-27 + REAL(DOUBLE), PARAMETER :: RINFEV = 13.605693009D00 + REAL(DOUBLE), PARAMETER :: RINFK = 109737.31568508D00 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- @@ -69,8 +69,8 @@ SUBROUTINE SETCON ! ! Calculate constants for /DEF3/: ! - EMPAM = EMPAMU - RBCM = AINFCM + EMPAM = EMPAMU + RBCM = AINFCM ! ! Calculate constants for /DEF11/: ! @@ -78,8 +78,8 @@ SUBROUTINE SETCON ! B1 is the conversion factor between the amu and the atomic ! unit of mass ! - CVAC = ALFAI - AUMAMU = EMEAMU + CVAC = ALFAI + AUMAMU = EMEAMU ! ! Calculate constants for /DEF10/: ! @@ -94,26 +94,26 @@ SUBROUTINE SETCON ! FBSI converts the Einstein B coefficients from atomic to SI ! units ! - AUCM = 2.0D00*RINFK - AUEV = 2.0D00*RINFEV - CCMS = CCMPS - FASI = (EMEG/HBARES)*(EESU*EESU/HBARES)**2 - FBSI = (10.0D00*AINFCM**3/HBARES)*FASI + AUCM = 2.0D00*RINFK + AUEV = 2.0D00*RINFEV + CCMS = CCMPS + FASI = (EMEG/HBARES)*(EESU*EESU/HBARES)**2 + FBSI = (10.0D00*AINFCM**3/HBARES)*FASI ! ! Calculate conversion factor for Fermis to Bohr radii ! - FMTOAU = 1.0D-13/AINFCM + FMTOAU = 1.0D-13/AINFCM ! ! Calculate \pi from FORTRAN function ! - PI = 4.0D00*ATAN(1.0D00) + PI = 4.0D00*ATAN(1.0D00) ! ! Printouts ! IF (LDBPG(2)) WRITE (99, 300) AINFCM, ALFAI, CCMPS, EESU, EMEG, EMEAMU, & - EMPAMU, HBARES, RINFEV, RINFK + EMPAMU, HBARES, RINFEV, RINFK ! - RETURN + RETURN ! 300 FORMAT(/,'From SUBROUTINE SETCON:'/,' AINFCM (Bohr radius in cm): ',0P,1D& 16.9,','/,' ALFAI (Inverse of the fine-structure constant): ',3P,1D& @@ -124,7 +124,7 @@ SUBROUTINE SETCON ' EMPAMU (Proton mass in u): ',1P,1D16.9,','/,& ' HBARES (Rationalized Planck constant in erg s): ',1P,1D15.8,','/,& ' RINFEV (Rydberg in eV): ',2P,1D15.8,','/,& - ' RINFK (Rydberg in Kaysers): ',6P,1D17.10,'.') - RETURN + ' RINFK (Rydberg in Kaysers): ',6P,1D17.10,'.') + RETURN ! - END SUBROUTINE SETCON + END SUBROUTINE SETCON diff --git a/src/lib/lib9290/setcon_I.f90 b/src/lib/lib9290/setcon_I.f90 index 34bf088d5..653697055 100644 --- a/src/lib/lib9290/setcon_I.f90 +++ b/src/lib/lib9290/setcon_I.f90 @@ -1,9 +1,9 @@ - MODULE setcon_I + MODULE setcon_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:28 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:28 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcon + SUBROUTINE setcon !VAST.../DEBUGG/ LDBPG(IN) !VAST.../DEF3/ EMPAM(OUT), RBCM(OUT) !VAST.../DEF9/ CVAC(OUT), PI(OUT) @@ -11,6 +11,6 @@ SUBROUTINE setcon !VAST.../DEF10/ FBSI(OUT) !VAST.../DEF11/ FMTOAU(OUT), AUMAMU(OUT) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setcsh.f90 b/src/lib/lib9290/setcsh.f90 index 86617985c..1eda6f450 100644 --- a/src/lib/lib9290/setcsh.f90 +++ b/src/lib/lib9290/setcsh.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! - SUBROUTINE SETCSH(NFILE, NAME, NCORE) + SUBROUTINE SETCSH(NFILE, NAME, NCORE) ! ! Open, check the CSL file and load the load (via lodcsh) data from ! the header lines. It is designed to replace all kinds of "setcsl" @@ -13,67 +13,67 @@ SUBROUTINE SETCSH(NFILE, NAME, NCORE) ! Written by Xinghone He Last revision: 23 Dec 1997 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:30 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:30 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE IOUNIT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE lodcsh_I + USE lodcsh_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NFILE - INTEGER :: NCORE + INTEGER :: NFILE + INTEGER :: NCORE CHARACTER (LEN = *), INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENGTH, IOS - LOGICAL :: FOUND - CHARACTER :: RECORD*15 + INTEGER :: LENGTH, IOS + LOGICAL :: FOUND + CHARACTER :: RECORD*15 !----------------------------------------------- ! ! ...Locals - - LENGTH = LEN_TRIM(NAME) - - INQUIRE(FILE=NAME, EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (ISTDE, *) NAME(1:LENGTH), ' does not exist' - STOP - ENDIF - - INQUIRE(UNIT=NFILE, OPENED=FOUND) - IF (FOUND) THEN - WRITE (ISTDE, *) 'Unit ', NFILE, ' has been used elsewhere' - STOP - ENDIF - - OPEN(NFILE, FILE=NAME, STATUS='OLD', IOSTAT=IOS, POSITION='asis') - IF (IOS /= 0) THEN - WRITE (ISTDE, *) 'Error when opening ', NAME - STOP - ENDIF + + LENGTH = LEN_TRIM(NAME) + + INQUIRE(FILE=NAME, EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (ISTDE, *) NAME(1:LENGTH), ' does not exist' + STOP + ENDIF + + INQUIRE(UNIT=NFILE, OPENED=FOUND) + IF (FOUND) THEN + WRITE (ISTDE, *) 'Unit ', NFILE, ' has been used elsewhere' + STOP + ENDIF + + OPEN(NFILE, FILE=NAME, STATUS='OLD', IOSTAT=IOS, POSITION='asis') + IF (IOS /= 0) THEN + WRITE (ISTDE, *) 'Error when opening ', NAME + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (NFILE, '(1A15)', IOSTAT=IOS) RECORD - - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (ISTDE, *) 'Not a Configuration Symmetry List File;' - CLOSE(NFILE) - STOP - ENDIF + READ (NFILE, '(1A15)', IOSTAT=IOS) RECORD + + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (ISTDE, *) 'Not a Configuration Symmetry List File;' + CLOSE(NFILE) + STOP + ENDIF ! ! Load data from the .csl file ! - CALL LODCSH (NFILE, NCORE) - - RETURN - END SUBROUTINE SETCSH + CALL LODCSH (NFILE, NCORE) + + RETURN + END SUBROUTINE SETCSH diff --git a/src/lib/lib9290/setcsh_I.f90 b/src/lib/lib9290/setcsh_I.f90 index e0f1b4a4c..73ba1c423 100644 --- a/src/lib/lib9290/setcsh_I.f90 +++ b/src/lib/lib9290/setcsh_I.f90 @@ -1,15 +1,15 @@ - MODULE setcsh_I + MODULE setcsh_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:30 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:30 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsh (NFILE, NAME, NCORE) - INTEGER, INTENT(IN) :: NFILE - CHARACTER (LEN = *), INTENT(IN) :: NAME - INTEGER :: NCORE + SUBROUTINE setcsh (NFILE, NAME, NCORE) + INTEGER, INTENT(IN) :: NFILE + CHARACTER (LEN = *), INTENT(IN) :: NAME + INTEGER :: NCORE !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: LODCSH !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setcsla.f90 b/src/lib/lib9290/setcsla.f90 index f7853c799..6ab537012 100644 --- a/src/lib/lib9290/setcsla.f90 +++ b/src/lib/lib9290/setcsla.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETCSLA(NAME, NCORE) + SUBROUTINE SETCSLA(NAME, NCORE) ! * ! Open, check, load data from and close the .csl file. This file * ! is always attached to stream 21. * @@ -11,63 +11,63 @@ SUBROUTINE SETCSLA(NAME, NCORE) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:33 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:33 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE IOUNIT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodcsl_I + USE openfl_I + USE lodcsl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NCORE + INTEGER :: NCORE CHARACTER (LEN = 24), INTENT(IN) :: NAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: K, IERR, IOS - CHARACTER(LEN=3) :: STATUS - CHARACTER(LEN=9) :: FORM - CHARACTER(LEN=15) :: RECORD - CHARACTER(LEN=256) :: FILNAM + INTEGER :: K, IERR, IOS + CHARACTER(LEN=3) :: STATUS + CHARACTER(LEN=9) :: FORM + CHARACTER(LEN=15) :: RECORD + CHARACTER(LEN=256) :: FILNAM !----------------------------------------------- ! ! The .csl file is FORMATTED; it must exist ! - K = INDEX(NAME,' ') - FILNAM = NAME(1:K-1)//'.c' - FORM = 'FORMATTED' - STATUS = 'OLD' - + K = INDEX(NAME,' ') + FILNAM = NAME(1:K-1)//'.c' + FORM = 'FORMATTED' + STATUS = 'OLD' + ! - CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) - IF (IERR == 1) THEN - WRITE (ISTDE, *) 'Error when opening', FILNAM - STOP - ENDIF + CALL OPENFL (21, FILNAM, FORM, STATUS, IERR) + IF (IERR == 1) THEN + WRITE (ISTDE, *) 'Error when opening', FILNAM + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (21, '(1A15)', IOSTAT=IOS) RECORD - IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN - WRITE (ISTDE, *) 'Not a Configuration Symmetry List File;' - CLOSE(21) - ENDIF + READ (21, '(1A15)', IOSTAT=IOS) RECORD + IF (IOS/=0 .OR. RECORD(1:15)/='Core subshells:') THEN + WRITE (ISTDE, *) 'Not a Configuration Symmetry List File;' + CLOSE(21) + ENDIF ! ! Load data from the .csl file ! - CALL LODCSL (NCORE) + CALL LODCSL (NCORE) ! ! Close the .csl file ! - CLOSE(21) + CLOSE(21) ! - RETURN - END SUBROUTINE SETCSLA + RETURN + END SUBROUTINE SETCSLA diff --git a/src/lib/lib9290/setcsla_I.f90 b/src/lib/lib9290/setcsla_I.f90 index 3e3ef2d91..090a80b9e 100644 --- a/src/lib/lib9290/setcsla_I.f90 +++ b/src/lib/lib9290/setcsla_I.f90 @@ -1,14 +1,14 @@ - MODULE setcsla_I + MODULE setcsla_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:33 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:33 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsla (NAME, NCORE) - CHARACTER (LEN = 24), INTENT(IN) :: NAME - INTEGER :: NCORE + SUBROUTINE setcsla (NAME, NCORE) + CHARACTER (LEN = 24), INTENT(IN) :: NAME + INTEGER :: NCORE !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: OPENFL, LODCSL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setcsll.f90 b/src/lib/lib9290/setcsll.f90 index 58e66dcc1..2b4ef1555 100644 --- a/src/lib/lib9290/setcsll.f90 +++ b/src/lib/lib9290/setcsll.f90 @@ -1,101 +1,101 @@ !*********************************************************************** - SUBROUTINE SETCSLL(NUNIT, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) + SUBROUTINE SETCSLL(NUNIT, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) ! ! Open, read name file to get nblock, ncfblk(), idblk(), ncftot ! ! Xinghong He 98-06-29 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:34 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:34 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I + USE openfl_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: NUNIT - INTEGER, INTENT(IN) :: NBLKIN - INTEGER, INTENT(OUT) :: NBLOCK - INTEGER, INTENT(OUT) :: NCFTOT + INTEGER :: NUNIT + INTEGER, INTENT(IN) :: NBLKIN + INTEGER, INTENT(OUT) :: NBLOCK + INTEGER, INTENT(OUT) :: NCFTOT CHARACTER (LEN = *), INTENT(INOUT) :: NAME INTEGER, DIMENSION(*), INTENT(INOUT) :: NCFBLK CHARACTER (LEN = 8), DIMENSION(*), INTENT(OUT) :: IDBLK !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, NCSF, IOS, IERR - LOGICAL :: FOUND + INTEGER :: I, NCSF, IOS, IERR + LOGICAL :: FOUND CHARACTER :: STR*15, CH*2, LINE3*200 !----------------------------------------------- ! Locals - + ! Look for - - INQUIRE(FILE=NAME, EXIST=FOUND) - IF (.NOT.FOUND) THEN - WRITE (6, *) NAME(1:LEN_TRIM(NAME)), ' does not exist' - STOP - ENDIF - + + INQUIRE(FILE=NAME, EXIST=FOUND) + IF (.NOT.FOUND) THEN + WRITE (6, *) NAME(1:LEN_TRIM(NAME)), ' does not exist' + STOP + ENDIF + ! Open it - - CALL OPENFL (NUNIT, NAME, 'FORMATTED', 'OLD', IERR) - IF (IERR == 1) THEN - WRITE (6, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) - STOP - ENDIF - + + CALL OPENFL (NUNIT, NAME, 'FORMATTED', 'OLD', IERR) + IF (IERR == 1) THEN + WRITE (6, *) 'Error when opening ', NAME(1:LEN_TRIM(NAME)) + STOP + ENDIF + ! Check the first record of the file; if not as expected, stop - - READ (NUNIT, '(1A15)', IOSTAT=IOS) STR - IF (IOS/=0 .OR. STR/='Core subshells:') THEN - WRITE (6, *) 'Not a Configuration Symmetry List File;' - CLOSE(NUNIT) - STOP - ENDIF - + + READ (NUNIT, '(1A15)', IOSTAT=IOS) STR + IF (IOS/=0 .OR. STR/='Core subshells:') THEN + WRITE (6, *) 'Not a Configuration Symmetry List File;' + CLOSE(NUNIT) + STOP + ENDIF + ! Skip next 4 records - - DO I = 1, 4 - READ (NUNIT, *) - END DO - + + DO I = 1, 4 + READ (NUNIT, *) + END DO + ! Determine the number of blocks in this file - - NBLOCK = 0 - NCSF = 0 - - IOS = 0 - DO WHILE(IOS == 0) - READ (NUNIT, '(1A2)', IOSTAT=IOS) CH - IF (CH==' *' .OR. IOS/=0) THEN + + NBLOCK = 0 + NCSF = 0 + + IOS = 0 + DO WHILE(IOS == 0) + READ (NUNIT, '(1A2)', IOSTAT=IOS) CH + IF (CH==' *' .OR. IOS/=0) THEN !.. a new block has been found - NBLOCK = NBLOCK + 1 - WRITE (6, *) 'Block ', NBLOCK, ', ncf = ', NCSF - IF (NBLOCK > NBLKIN) THEN - WRITE (6, *) 'setcsll: Too many blocks(', NBLOCK, ')' - WRITE (6, *) 'Maximum allowed is ', NBLKIN - STOP - ENDIF - I = LEN_TRIM(LINE3) - IDBLK(NBLOCK) = LINE3(I-4:I) - NCFBLK(NBLOCK) = NCSF - NCSF = 0 - IF (IOS == 0) CYCLE - ELSE - READ (NUNIT, *) - READ (NUNIT, '(A)') LINE3 - NCSF = NCSF + 1 - ENDIF - END DO - + NBLOCK = NBLOCK + 1 + WRITE (6, *) 'Block ', NBLOCK, ', ncf = ', NCSF + IF (NBLOCK > NBLKIN) THEN + WRITE (6, *) 'setcsll: Too many blocks(', NBLOCK, ')' + WRITE (6, *) 'Maximum allowed is ', NBLKIN + STOP + ENDIF + I = LEN_TRIM(LINE3) + IDBLK(NBLOCK) = LINE3(I-4:I) + NCFBLK(NBLOCK) = NCSF + NCSF = 0 + IF (IOS == 0) CYCLE + ELSE + READ (NUNIT, *) + READ (NUNIT, '(A)') LINE3 + NCSF = NCSF + 1 + ENDIF + END DO + ! Obtain ncftot - - NCFTOT = SUM(NCFBLK(:NBLOCK)) - - RETURN - END SUBROUTINE SETCSLL + + NCFTOT = SUM(NCFBLK(:NBLOCK)) + + RETURN + END SUBROUTINE SETCSLL diff --git a/src/lib/lib9290/setcsll_I.f90 b/src/lib/lib9290/setcsll_I.f90 index 795ed955b..45d24e97b 100644 --- a/src/lib/lib9290/setcsll_I.f90 +++ b/src/lib/lib9290/setcsll_I.f90 @@ -1,18 +1,18 @@ - MODULE setcsll_I + MODULE setcsll_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:34 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:34 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setcsll (NUNIT, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) - INTEGER, INTENT(IN) :: NUNIT - CHARACTER (LEN = *), INTENT(INOUT) :: NAME - INTEGER, INTENT(IN) :: NBLKIN - INTEGER, INTENT(OUT) :: NBLOCK - INTEGER, DIMENSION(*), INTENT(INOUT) :: NCFBLK - INTEGER, INTENT(OUT) :: NCFTOT - CHARACTER (LEN = 8), DIMENSION(*), INTENT(OUT) :: IDBLK + SUBROUTINE setcsll (NUNIT, NAME, NBLKIN, NBLOCK, NCFBLK, NCFTOT, IDBLK) + INTEGER, INTENT(IN) :: NUNIT + CHARACTER (LEN = *), INTENT(INOUT) :: NAME + INTEGER, INTENT(IN) :: NBLKIN + INTEGER, INTENT(OUT) :: NBLOCK + INTEGER, DIMENSION(*), INTENT(INOUT) :: NCFBLK + INTEGER, INTENT(OUT) :: NCFTOT + CHARACTER (LEN = 8), DIMENSION(*), INTENT(OUT) :: IDBLK !VAST...Calls: OPENFL !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setiso.f90 b/src/lib/lib9290/setiso.f90 index e529ee213..a815f354a 100644 --- a/src/lib/lib9290/setiso.f90 +++ b/src/lib/lib9290/setiso.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETISO(FNAME) + SUBROUTINE SETISO(FNAME) ! * ! Open, check, load data from and close the .iso file. This file * ! is always attached to stream 22 in RSCF92, RCI92, HFS92, and * @@ -16,18 +16,18 @@ SUBROUTINE SETISO(FNAME) ! Modified by G. Gaigalas, May 2011 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:35 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:35 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE IOUNIT_C + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodiso_I + USE openfl_I + USE lodiso_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -36,45 +36,45 @@ SUBROUTINE SETISO(FNAME) !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - CHARACTER(LEN=3), PARAMETER :: STATUS = 'OLD' - CHARACTER(LEN=6), PARAMETER :: MYNAME = 'SETISO' - CHARACTER(LEN=9), PARAMETER :: FORM = 'FORMATTED' - CHARACTER(LEN=14), PARAMETER :: SIGNATURE = 'Atomic number:' + CHARACTER(LEN=3), PARAMETER :: STATUS = 'OLD' + CHARACTER(LEN=6), PARAMETER :: MYNAME = 'SETISO' + CHARACTER(LEN=9), PARAMETER :: FORM = 'FORMATTED' + CHARACTER(LEN=14), PARAMETER :: SIGNATURE = 'Atomic number:' !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: LENF, IERR, IOS - LOGICAL :: FOUND - CHARACTER(LEN=14) :: STR + INTEGER :: LENF, IERR, IOS + LOGICAL :: FOUND + CHARACTER(LEN=14) :: STR !----------------------------------------------- ! - INQUIRE(FILE=FNAME, EXIST=FOUND) - IF (.NOT.FOUND) THEN - LENF = LEN_TRIM(FNAME) + INQUIRE(FILE=FNAME, EXIST=FOUND) + IF (.NOT.FOUND) THEN + LENF = LEN_TRIM(FNAME) WRITE (ISTDE,*) & - MYNAME,'- file: ',FNAME(1:LENF),' does not exist' - STOP - ENDIF + MYNAME,'- file: ',FNAME(1:LENF),' does not exist' + STOP + ENDIF ! - CALL OPENFL (22, FNAME, FORM, STATUS, IERR) - IF (IERR /= 0) THEN - WRITE (ISTDE, *) 'Error opening isodata file: ', FNAME(1:LENF) - STOP - ENDIF + CALL OPENFL (22, FNAME, FORM, STATUS, IERR) + IF (IERR /= 0) THEN + WRITE (ISTDE, *) 'Error opening isodata file: ', FNAME(1:LENF) + STOP + ENDIF ! ! Check the first record of the file; if not as expected, try again ! - READ (22, '(A)', IOSTAT=IOS) STR - IF (IOS/=0 .OR. STR/=SIGNATURE) THEN - WRITE (ISTDE, *) 'Not an ISOtope Data File;' - CLOSE(22) - STOP - ENDIF + READ (22, '(A)', IOSTAT=IOS) STR + IF (IOS/=0 .OR. STR/=SIGNATURE) THEN + WRITE (ISTDE, *) 'Not an ISOtope Data File;' + CLOSE(22) + STOP + ENDIF ! ! Load data from the .iso file and then close it. ! - CALL LODISO - CLOSE(22) - - RETURN - END SUBROUTINE SETISO + CALL LODISO + CLOSE(22) + + RETURN + END SUBROUTINE SETISO diff --git a/src/lib/lib9290/setiso_I.f90 b/src/lib/lib9290/setiso_I.f90 index 518ba6d70..56049a211 100644 --- a/src/lib/lib9290/setiso_I.f90 +++ b/src/lib/lib9290/setiso_I.f90 @@ -1,13 +1,13 @@ - MODULE setiso_I + MODULE setiso_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:35 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:35 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setiso (FNAME) - CHARACTER (LEN = *), INTENT(IN) :: FNAME + SUBROUTINE setiso (FNAME) + CHARACTER (LEN = *), INTENT(IN) :: FNAME !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: OPENFL, LODISO !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setj.f90 b/src/lib/lib9290/setj.f90 index 18690130e..98788fb61 100644 --- a/src/lib/lib9290/setj.f90 +++ b/src/lib/lib9290/setj.f90 @@ -1,155 +1,155 @@ !*********************************************************************** ! * - SUBROUTINE SETJ(IS, JS, KS, NS, KJ23) + SUBROUTINE SETJ(IS, JS, KS, NS, KJ23) ! * ! Sets the tables required by the recoupling coefficient package * ! ! !----------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:36 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:36 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE L1_C - USE L2_C - USE M_C, ONLY: JJC1, JJC2, JJQ1, JJQ2, JLIST - USE COUPLE_C, ONLY: MJA, NJA, J1, J2, J3, MANGM + USE L1_C + USE L2_C + USE M_C, ONLY: JJC1, JJC2, JJQ1, JJQ2, JLIST + USE COUPLE_C, ONLY: MJA, NJA, J1, J2, J3, MANGM IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NS - INTEGER, INTENT(INOUT) :: KJ23 + INTEGER, INTENT(IN) :: NS + INTEGER, INTENT(INOUT) :: KJ23 INTEGER, DIMENSION(2,2), INTENT(IN) :: IS INTEGER, DIMENSION(2,2), INTENT(IN) :: JS INTEGER, DIMENSION(2,2), INTENT(IN) :: KS !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II, IJ, I, NS1, NS2, NS3, IJ1, IJ2, J + INTEGER :: II, IJ, I, NS1, NS2, NS3, IJ1, IJ2, J !----------------------------------------------- ! ! ! 1.0 Set J1 array ! - II = 0 - IF (NS > 0) THEN - J1(:NS) = JBQ1(3,JLIST(:NS)) - II = NS - ENDIF - IF (NS /= 1) THEN - NS1 = NS - 1 - IF (NS1 > 0) THEN - J1(II+1:NS1+II) = JJC1(:NS1) - II = NS1 + II - ENDIF - IF (NS1 > 0) THEN - J1(II+1:NS1+II) = JJC2(:NS1) - II = NS1 + II - ENDIF - ENDIF - DO I = 1, 2 - II = II + 1 - IJ = IS(I,1) - J1(II) = JJQ1(3,IJ) - IF (I==1 .AND. IS(1,1)==IS(2,1)) J1(II) = JTQ1(3) - J1(II+4) = KS(I,1) - END DO - DO I = 1, 2 - II = II + 1 - IJ = IS(I,2) - J1(II) = JJQ2(3,IJ) - IF (I==1 .AND. IS(1,2)==IS(2,2)) J1(II) = JTQ2(3) - J1(II+4) = KS(I,2) - END DO + II = 0 + IF (NS > 0) THEN + J1(:NS) = JBQ1(3,JLIST(:NS)) + II = NS + ENDIF + IF (NS /= 1) THEN + NS1 = NS - 1 + IF (NS1 > 0) THEN + J1(II+1:NS1+II) = JJC1(:NS1) + II = NS1 + II + ENDIF + IF (NS1 > 0) THEN + J1(II+1:NS1+II) = JJC2(:NS1) + II = NS1 + II + ENDIF + ENDIF + DO I = 1, 2 + II = II + 1 + IJ = IS(I,1) + J1(II) = JJQ1(3,IJ) + IF (I==1 .AND. IS(1,1)==IS(2,1)) J1(II) = JTQ1(3) + J1(II+4) = KS(I,1) + END DO + DO I = 1, 2 + II = II + 1 + IJ = IS(I,2) + J1(II) = JJQ2(3,IJ) + IF (I==1 .AND. IS(1,2)==IS(2,2)) J1(II) = JTQ2(3) + J1(II+4) = KS(I,2) + END DO ! ! 2.0 Set J2, J3 arrays if not already available ! - NS2 = MAX(4,NS + 2) - IF (KJ23 <= 0) THEN + NS2 = MAX(4,NS + 2) + IF (KJ23 <= 0) THEN ! - DO I = 4, NS2 - J2(I,1) = NS + I - 4 - J2(I,2) = I - 2 - J2(I,3) = NS + I - 3 - J3(I,1) = J2(I,1) + NS - 1 - J3(I,2) = I - 2 - J3(I,3) = J2(I,3) + NS - 1 - END DO - J2(4,1) = 1 - J3(4,1) = 1 + DO I = 4, NS2 + J2(I,1) = NS + I - 4 + J2(I,2) = I - 2 + J2(I,3) = NS + I - 3 + J3(I,1) = J2(I,1) + NS - 1 + J3(I,2) = I - 2 + J3(I,3) = J2(I,3) + NS - 1 + END DO + J2(4,1) = 1 + J3(4,1) = 1 ! ! At this stage, the entries in rows corresponding to active ! shells are set incorrectly. ! ! 3.0 Set rows 1 through 3 ! - NS3 = 3*NS - J2(1,1) = NS3 + 5 - J2(1,2) = NS3 + 7 - J2(1,3) = NS3 + 3 - J2(2,1) = JS(1,1) - J2(2,2) = NS3 + 3 - J2(2,3) = NS3 - 1 - J2(3,1) = JS(2,1) - J2(3,2) = NS3 + 4 - J2(3,3) = NS3 -! - J3(1,1) = NS3 + 7 - J3(1,2) = NS3 + 4 - J3(1,3) = NS3 + 6 - J3(2,1) = JS(1,2) - J3(2,2) = NS3 + 5 - J3(2,3) = NS3 + 1 - J3(3,1) = JS(2,2) - J3(3,2) = NS3 + 6 - J3(3,3) = NS3 + 2 + NS3 = 3*NS + J2(1,1) = NS3 + 5 + J2(1,2) = NS3 + 7 + J2(1,3) = NS3 + 3 + J2(2,1) = JS(1,1) + J2(2,2) = NS3 + 3 + J2(2,3) = NS3 - 1 + J2(3,1) = JS(2,1) + J2(3,2) = NS3 + 4 + J2(3,3) = NS3 +! + J3(1,1) = NS3 + 7 + J3(1,2) = NS3 + 4 + J3(1,3) = NS3 + 6 + J3(2,1) = JS(1,2) + J3(2,2) = NS3 + 5 + J3(2,3) = NS3 + 1 + J3(3,1) = JS(2,2) + J3(3,2) = NS3 + 6 + J3(3,3) = NS3 + 2 ! ! 4.0 Set remaining resultants ! - IJ1 = JS(1,1) - IJ2 = JS(2,1) - IF (IJ2 > 1) J2(IJ2+2,2) = J2(3,3) - IF (IJ2 == 1) J2(4,1) = J2(3,3) - IF (IJ1 == IJ2) THEN - J2(3,1) = J2(2,3) - ELSE -! - IF (IJ1 > 1) J2(IJ1+2,2) = J2(2,3) - IF (IJ1 == 1) J2(4,1) = J2(2,3) - ENDIF -! - IJ1 = JS(1,2) - IJ2 = JS(2,2) - IF (IJ2 > 1) J3(IJ2+2,2) = J3(3,3) - IF (IJ2 == 1) J3(4,1) = J3(3,3) - IF (IJ1 == IJ2) THEN - J3(3,1) = J3(2,3) - ELSE -! - IF (IJ1 > 1) J3(IJ1+2,2) = J3(2,3) - IF (IJ1 == 1) J3(4,1) = J3(2,3) - ENDIF + IJ1 = JS(1,1) + IJ2 = JS(2,1) + IF (IJ2 > 1) J2(IJ2+2,2) = J2(3,3) + IF (IJ2 == 1) J2(4,1) = J2(3,3) + IF (IJ1 == IJ2) THEN + J2(3,1) = J2(2,3) + ELSE +! + IF (IJ1 > 1) J2(IJ1+2,2) = J2(2,3) + IF (IJ1 == 1) J2(4,1) = J2(2,3) + ENDIF +! + IJ1 = JS(1,2) + IJ2 = JS(2,2) + IF (IJ2 > 1) J3(IJ2+2,2) = J3(3,3) + IF (IJ2 == 1) J3(4,1) = J3(3,3) + IF (IJ1 == IJ2) THEN + J3(3,1) = J3(2,3) + ELSE +! + IF (IJ1 > 1) J3(IJ1+2,2) = J3(2,3) + IF (IJ1 == 1) J3(4,1) = J3(2,3) + ENDIF ! ! All arrays now set. Put up flag KJ23. ! - KJ23 = 1 - MJA = NS3 + 7 - NJA = NS + 3 + KJ23 = 1 + MJA = NS3 + 7 + NJA = NS + 3 ! ! 5.0 Save J2, J3 and return ! - J2S(:NS2,:) = J2(:NS2,:) - J3S(:NS2,:) = J3(:NS2,:) - RETURN - ENDIF + J2S(:NS2,:) = J2(:NS2,:) + J3S(:NS2,:) = J3(:NS2,:) + RETURN + ENDIF ! ! 6.0 Reset J2, J3 from buffers if KJ23 has been set ! - J2(:NS2,:) = J2S(:NS2,:) - J3(:NS2,:) = J3S(:NS2,:) - RETURN + J2(:NS2,:) = J2S(:NS2,:) + J3(:NS2,:) = J3S(:NS2,:) + RETURN ! - END SUBROUTINE SETJ + END SUBROUTINE SETJ diff --git a/src/lib/lib9290/setj_I.f90 b/src/lib/lib9290/setj_I.f90 index 80abe2264..d9991a8d5 100644 --- a/src/lib/lib9290/setj_I.f90 +++ b/src/lib/lib9290/setj_I.f90 @@ -1,24 +1,24 @@ - MODULE setj_I + MODULE setj_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:36 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:36 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setj (IS, JS, KS, NS, KJ23) - INTEGER MANGM - PARAMETER(MANGM=60) - INTEGER MTRIAD - PARAMETER(MTRIAD=12) - INTEGER, DIMENSION(2,2), INTENT(IN) :: IS - INTEGER, DIMENSION(2,2), INTENT(IN) :: JS - INTEGER, DIMENSION(2,2), INTENT(IN) :: KS - INTEGER, INTENT(IN) :: NS - INTEGER, INTENT(INOUT) :: KJ23 + SUBROUTINE setj (IS, JS, KS, NS, KJ23) + INTEGER MANGM + PARAMETER(MANGM=60) + INTEGER MTRIAD + PARAMETER(MTRIAD=12) + INTEGER, DIMENSION(2,2), INTENT(IN) :: IS + INTEGER, DIMENSION(2,2), INTENT(IN) :: JS + INTEGER, DIMENSION(2,2), INTENT(IN) :: KS + INTEGER, INTENT(IN) :: NS + INTEGER, INTENT(INOUT) :: KJ23 !VAST.../L1/ JBQ1(IN), JTQ1(IN), JTQ2(IN) !VAST.../L2/ J2S(INOUT), J3S(INOUT) !VAST.../M0/ JJC1(IN), JJC2(IN) !VAST.../M2/ JJQ1(IN), JJQ2(IN) !VAST.../M3/ JLIST(IN) !VAST.../COUPLE/ MJA(OUT), NJA(OUT), J1(OUT), J2(INOUT), J3(INOUT) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setmc.f90 b/src/lib/lib9290/setmc.f90 index 4f78fae2f..3b545aafb 100644 --- a/src/lib/lib9290/setmc.f90 +++ b/src/lib/lib9290/setmc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETMC + SUBROUTINE SETMC ! * ! This subprogram sets machine-dependent parameters. * ! * @@ -9,15 +9,15 @@ SUBROUTINE SETMC ! Written by Farid A Parpia Last updated: 06 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:37 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:37 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE DEF_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE DEF_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- @@ -25,7 +25,7 @@ SUBROUTINE SETMC !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: DNUM + REAL(DOUBLE) :: DNUM REAL(DOUBLE) :: DLAMCH !----------------------------------------------- ! @@ -34,32 +34,32 @@ SUBROUTINE SETMC ! ! TENMAX - Maximum size of exponent of 10 ! - TENMAX = DLAMCH('L') + TENMAX = DLAMCH('L') ! ! EXPMAX - Maximum size of exponent of e ! - DNUM = DLAMCH('O') - EXPMAX = LOG(DNUM) + DNUM = DLAMCH('O') + EXPMAX = LOG(DNUM) ! ! EXPMIN - Minimum size of exponent of e ! - DNUM = DLAMCH('U') - EXPMIN = LOG(DNUM) + DNUM = DLAMCH('U') + EXPMIN = LOG(DNUM) ! ! PRECIS - Machine precision ! - PRECIS = DLAMCH('E') + PRECIS = DLAMCH('E') ! ! Debug printout ! - IF (LDBPG(1)) WRITE (99, 300) TENMAX, EXPMAX, EXPMIN, PRECIS + IF (LDBPG(1)) WRITE (99, 300) TENMAX, EXPMAX, EXPMIN, PRECIS ! - RETURN + RETURN ! 300 FORMAT(/,'From SUBROUTINE SETMC:'/,' TENMAX (maximum exponent of 10): ',& F5.0,/,' EXPMAX (maximum exponent of e): ',1P,1D19.12,/,& ' EXPMIN (minimum exponent of e): ',1D19.12,/,& - ' PRECIS (machine precision): ',1D19.12) - RETURN + ' PRECIS (machine precision): ',1D19.12) + RETURN ! - END SUBROUTINE SETMC + END SUBROUTINE SETMC diff --git a/src/lib/lib9290/setmc_I.f90 b/src/lib/lib9290/setmc_I.f90 index 1df47b914..c7ab8df65 100644 --- a/src/lib/lib9290/setmc_I.f90 +++ b/src/lib/lib9290/setmc_I.f90 @@ -1,13 +1,13 @@ - MODULE setmc_I + MODULE setmc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:37 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:37 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setmc + SUBROUTINE setmc !VAST.../DEBUGG/ LDBPG(IN) !VAST.../DEF0/ TENMAX(OUT), EXPMAX(OUT), EXPMIN(OUT), PRECIS(OUT) !VAST...Calls: DLAMCH !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setpot.f90 b/src/lib/lib9290/setpot.f90 index ab8c3fbe8..99504f3c1 100644 --- a/src/lib/lib9290/setpot.f90 +++ b/src/lib/lib9290/setpot.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETPOT(J, JP) + SUBROUTINE SETPOT(J, JP) ! * ! This subroutine sets up the arrays TF and TG for use by the * ! subprograms IN, OUT, and SBSTEP. * @@ -13,67 +13,67 @@ SUBROUTINE SETPOT(J, JP) ! Written by Farid A Parpia, at Oxford Last update: 16 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE IOUNIT_C - USE DEF_C - USE GRID_C - USE INT_C, ONLY: TF, TG - USE ORB_C - USE POTE_C, ONLY: YP + USE vast_kind_param, ONLY: DOUBLE + USE IOUNIT_C + USE DEF_C + USE GRID_C + USE INT_C, ONLY: TF, TG + USE ORB_C + USE POTE_C, ONLY: YP IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(OUT) :: JP + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(OUT) :: JP !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: DMHB2C, ENERGY, ENEFAC, RPI, YPRPOR - LOGICAL :: NOTSET + INTEGER :: I + REAL(DOUBLE) :: DMHB2C, ENERGY, ENEFAC, RPI, YPRPOR + LOGICAL :: NOTSET !----------------------------------------------- ! ! - NOTSET = .TRUE. + NOTSET = .TRUE. ! ! Define constants ! - DMHB2C = -H/(2.0D00*C) - ENERGY = E(J) - ENEFAC = 2.0D00*C*C - ENERGY + DMHB2C = -H/(2.0D00*C) + ENERGY = E(J) + ENEFAC = 2.0D00*C*C - ENERGY ! ! Set up arrays TF and TG ! ! Since TF(1) and TG(1) are never used, set them ! to some arbitrary value ! - JP = 0 - TF(1) = 0.0D00 - TG(1) = 0.0D00 - DO I = 2, N - RPI = RP(I) - YPRPOR = YP(I)*RPOR(I) - TF(I) = DMHB2C*(ENEFAC*RPI + YPRPOR) - TG(I) = DMHB2C*(ENERGY*RPI - YPRPOR) - IF (.NOT.NOTSET) CYCLE - IF (ABS(SIGN(1.0D00,TG(I))+SIGN(1.0D00,TG(1))) >= ACCY) CYCLE - JP = I - NOTSET = .FALSE. - END DO + JP = 0 + TF(1) = 0.0D00 + TG(1) = 0.0D00 + DO I = 2, N + RPI = RP(I) + YPRPOR = YP(I)*RPOR(I) + TF(I) = DMHB2C*(ENEFAC*RPI + YPRPOR) + TG(I) = DMHB2C*(ENERGY*RPI - YPRPOR) + IF (.NOT.NOTSET) CYCLE + IF (ABS(SIGN(1.0D00,TG(I))+SIGN(1.0D00,TG(1))) >= ACCY) CYCLE + JP = I + NOTSET = .FALSE. + END DO ! ! Trap for inappropriate grid ! - IF (JP == 0) THEN - WRITE (ISTDE, *) 'SETPOT: Grid of insufficient extent.' - STOP - ENDIF + IF (JP == 0) THEN + WRITE (ISTDE, *) 'SETPOT: Grid of insufficient extent.' + STOP + ENDIF ! - RETURN - END SUBROUTINE SETPOT + RETURN + END SUBROUTINE SETPOT diff --git a/src/lib/lib9290/setpot_I.f90 b/src/lib/lib9290/setpot_I.f90 index 3b375636b..cf912fc12 100644 --- a/src/lib/lib9290/setpot_I.f90 +++ b/src/lib/lib9290/setpot_I.f90 @@ -1,11 +1,11 @@ - MODULE setpot_I + MODULE setpot_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:38 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:38 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setpot (J, JP) - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(OUT) :: JP + SUBROUTINE setpot (J, JP) + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(OUT) :: JP !VAST.../IOUNIT/ ISTDE(IN) !VAST.../DEF2/ C(IN) !VAST.../DEF4/ ACCY(IN) @@ -14,6 +14,6 @@ SUBROUTINE setpot (J, JP) !VAST.../ORB1/ E(IN) !VAST.../POTE/ YP(IN) !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setqic.f90 b/src/lib/lib9290/setqic.f90 index 14825091f..15c9c0f99 100644 --- a/src/lib/lib9290/setqic.f90 +++ b/src/lib/lib9290/setqic.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETQIC + SUBROUTINE SETQIC ! * ! This subroutine sets up the coefficients for SUBROUTINEs DPBDT, * ! QUAD, RINTI, START, YZK, ZKF. * @@ -10,29 +10,29 @@ SUBROUTINE SETQIC ! Written by Farid A Parpia, at Oxford Last update: 05 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE CNC_C - USE GRID_C - USE LIC13_C, A13=>A - USE NCC_C - USE SBC_C + USE vast_kind_param, ONLY: DOUBLE + USE CNC_C + USE GRID_C + USE LIC13_C, A13=>A + USE NCC_C + USE SBC_C IMPLICIT NONE !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I, J - REAL(DOUBLE), DIMENSION(13,13) :: B13 - REAL(DOUBLE), DIMENSION(6) :: CG - REAL(DOUBLE), DIMENSION(5,2:5) :: C5NUM - REAL(DOUBLE), DIMENSION(6,2:6) :: C6NUM - REAL(DOUBLE) :: B13DEN, DENOM, C5DEN, C6DEN, FACTOR - LOGICAL :: FIRST + INTEGER :: I, J + REAL(DOUBLE), DIMENSION(13,13) :: B13 + REAL(DOUBLE), DIMENSION(6) :: CG + REAL(DOUBLE), DIMENSION(5,2:5) :: C5NUM + REAL(DOUBLE), DIMENSION(6,2:6) :: C6NUM + REAL(DOUBLE) :: B13DEN, DENOM, C5DEN, C6DEN, FACTOR + LOGICAL :: FIRST !----------------------------------------------- ! ! @@ -46,66 +46,66 @@ SUBROUTINE SETQIC -15807052800.0D00, 35126784000.0D00, -59276448000.0D00, & 75873853440.0D00, -73766246400.0D00, 54195609600.0D00, & -29638224000.0D00, 11708928000.0D00, -3161410560.0D00, 522547200.0D00& - , - 39916800.0D00/ + , - 39916800.0D00/ DATA (B13(2,I),I=1,13)/ -39916800.0D00, -967524480.0D00, 2634508800.0D00& , -4390848000.0D00, 6586272000.0D00, -7903526400.0D00, 7376624640.0D00& , -5269017600.0D00, 2822688000.0D00, -1097712000.0D00, 292723200.0D00& - , -47900160.0D00, 3628800.0D00/ + , -47900160.0D00, 3628800.0D00/ DATA (B13(3,I),I=1,13)/ 3628800.0D00, -87091200.0D00, -684478080.0D00, & 1596672000.0D00, -1796256000.0D00, 1916006400.0D00, -1676505600.0D00, & 1149603840.0D00, -598752000.0D00, 228096000.0D00, -59875200.0D00, & - 9676800.0D00, - 725760.0D00/ + 9676800.0D00, - 725760.0D00/ DATA (B13(4,I),I=1,13)/ -725760.0D00, 13063680.0D00, -143700480.0D00, & -476910720.0D00, 1077753600.0D00, -862202880.0D00, 670602240.0D00, & -431101440.0D00, 215550720.0D00, -79833600.0D00, 20528640.0D00, & - -3265920.0D00, 241920.0D00/ + -3265920.0D00, 241920.0D00/ DATA (B13(5,I),I=1,13)/ 241920.0D00, -3870720.0D00, 31933440.0D00, & -212889600.0D00, -303937920.0D00, 766402560.0D00, -447068160.0D00, & 255467520.0D00, -119750400.0D00, 42577920.0D00, -10644480.0D00, & - 1658880.0D00, - 120960.0D00/ + 1658880.0D00, - 120960.0D00/ DATA (B13(6,I),I=1,13)/ -120960.0D00, 1814400.0D00, -13305600.0D00, & 66528000.0D00, -299376000.0D00, -148262400.0D00, 558835200.0D00, & -239500800.0D00, 99792000.0D00, -33264000.0D00, 7983360.0D00, & - -1209600.0D00, 86400.0D00/ + -1209600.0D00, 86400.0D00/ DATA (B13(7,I),I=1,13)/ 86400.0D00, -1244160.0D00, 8553600.0D00, & -38016000.0D00, 128304000.0D00, -410572800.0D00, 0.0D00, & 410572800.0D00, -128304000.0D00, 38016000.0D00, -8553600.0D00, & - 1244160.0D00, - 86400.0D00/ + 1244160.0D00, - 86400.0D00/ DATA (B13(8,I),I=1,13)/ -86400.0D00, 1209600.0D00, -7983360.0D00, & 33264000.0D00, -99792000.0D00, 239500800.0D00, -558835200.0D00, & 148262400.0D00, 299376000.0D00, -66528000.0D00, 13305600.0D00, & - -1814400.0D00, 120960.0D00/ + -1814400.0D00, 120960.0D00/ DATA (B13(9,I),I=1,13)/ 120960.0D00, -1658880.0D00, 10644480.0D00, & -42577920.0D00, 119750400.0D00, -255467520.0D00, 447068160.0D00, & -766402560.0D00, 303937920.0D00, 212889600.0D00, -31933440.0D00, & - 3870720.0D00, - 241920.0D00/ + 3870720.0D00, - 241920.0D00/ DATA (B13(10,I),I=1,13)/ -241920.0D00, 3265920.0D00, -20528640.0D00, & 79833600.0D00, -215550720.0D00, 431101440.0D00, -670602240.0D00, & 862202880.0D00, -1077753600.0D00, 476910720.0D00, 143700480.0D00, & - -13063680.0D00, 725760.0D00/ + -13063680.0D00, 725760.0D00/ DATA (B13(11,I),I=1,13)/ 725760.0D00, -9676800.0D00, 59875200.0D00, & -228096000.0D00, 598752000.0D00, -1149603840.0D00, 1676505600.0D00, & -1916006400.0D00, 1796256000.0D00, -1596672000.0D00, 684478080.0D00, & - 87091200.0D00, - 3628800.0D00/ + 87091200.0D00, - 3628800.0D00/ DATA (B13(12,I),I=1,13)/ -3628800.0D00, 47900160.0D00, -292723200.0D00, & 1097712000.0D00, -2822688000.0D00, 5269017600.0D00, -7376624640.0D00, & 7903526400.0D00, -6586272000.0D00, 4390848000.0D00, -2634508800.0D00, & - 967524480.0D00, 39916800.0D00/ + 967524480.0D00, 39916800.0D00/ DATA (B13(13,I),I=1,13)/ 39916800.0D00, -522547200.0D00, 3161410560.0D00& , -11708928000.0D00, 29638224000.0D00, -54195609600.0D00, & 73766246400.0D00, -75873853440.0D00, 59276448000.0D00, & -35126784000.0D00, 15807052800.0D00, -5748019200.0D00, 1486442880.0D00& - / + / ! - DATA B13DEN/ 479001600.0D00/ + DATA B13DEN/ 479001600.0D00/ ! !----------------------------------------------------------------------* ! * ! Coefficients for Sienkiewicz-Baylis formula * ! - DATA CG/ 1771.0D00, 9235.0D00, 5890.0D00, 4610.0D00, 35.0D00, 59.0D00/ + DATA CG/ 1771.0D00, 9235.0D00, 5890.0D00, 4610.0D00, 35.0D00, 59.0D00/ ! - DATA DENOM/ 5760.0D00/ + DATA DENOM/ 5760.0D00/ ! !----------------------------------------------------------------------* ! * @@ -113,15 +113,15 @@ SUBROUTINE SETQIC ! pressed as rational numbers * ! DATA (C5NUM(I,2),I=1,5)/ 251.0D00, 646.0D00, -264.0D00, 106.0D00, - & - 19.0D00/ + 19.0D00/ DATA (C5NUM(I,3),I=1,5)/ 232.0D00, 992.0D00, 192.0D00, 32.0D00, - 8.0D00& - / + / DATA (C5NUM(I,4),I=1,5)/ 243.0D00, 918.0D00, 648.0D00, 378.0D00, - & - 27.0D00/ + 27.0D00/ DATA (C5NUM(I,5),I=1,5)/ 224.0D00, 1024.0D00, 384.0D00, 1024.0D00, & - 224.0D00/ + 224.0D00/ ! - DATA C5DEN/ 720.0D00/ + DATA C5DEN/ 720.0D00/ ! !----------------------------------------------------------------------* ! * @@ -129,21 +129,21 @@ SUBROUTINE SETQIC ! pressed as rational numbers * ! DATA (C6NUM(I,2),I=1,6)/ 475.0D00, 1427.0D00, -798.0D00, 482.0D00, & - -173.0D00, 27.0D00/ + -173.0D00, 27.0D00/ DATA (C6NUM(I,3),I=1,6)/ 448.0D00, 2064.0D00, 224.0D00, 224.0D00, & - -96.0D00, 16.0D00/ + -96.0D00, 16.0D00/ DATA (C6NUM(I,4),I=1,6)/ 459.0D00, 1971.0D00, 1026.0D00, 1026.0D00, & - -189.0D00, 27.0D00/ + -189.0D00, 27.0D00/ DATA (C6NUM(I,5),I=1,6)/ 448.0D00, 2048.0D00, 768.0D00, 2048.0D00, & - 448.0D00, 0.0D00/ + 448.0D00, 0.0D00/ DATA (C6NUM(I,6),I=1,6)/ 475.0D00, 1875.0D00, 1250.0D00, 1250.0D00, & - 1875.0D00, 475.0D00/ + 1875.0D00, 475.0D00/ ! - DATA C6DEN/ 1440.0D00/ + DATA C6DEN/ 1440.0D00/ ! !----------------------------------------------------------------------* ! - DATA FIRST/ .TRUE./ + DATA FIRST/ .TRUE./ ! ! Lagrange interpolation coefficients ! @@ -197,6 +197,6 @@ SUBROUTINE SETQIC 7 CONTINUE ! ! - RETURN + RETURN ! - END SUBROUTINE SETQIC + END SUBROUTINE SETQIC diff --git a/src/lib/lib9290/setqic_I.f90 b/src/lib/lib9290/setqic_I.f90 index 40d33e817..60265ec73 100644 --- a/src/lib/lib9290/setqic_I.f90 +++ b/src/lib/lib9290/setqic_I.f90 @@ -1,15 +1,15 @@ - MODULE setqic_I + MODULE setqic_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setqic + SUBROUTINE setqic !VAST.../CNC5/ CNC5C(OUT) !VAST.../GRID/ H(IN) !VAST.../CNC6/ CNC6C(OUT) !VAST.../LIC13/ A13(OUT) !VAST.../NCC/ C1(OUT), C2(OUT), C3(OUT), C4(OUT) !VAST.../SBC/ C(OUT) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setqna.f90 b/src/lib/lib9290/setqna.f90 index 7ccb49076..645062f1d 100644 --- a/src/lib/lib9290/setqna.f90 +++ b/src/lib/lib9290/setqna.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETQNA(JA, JB) + SUBROUTINE SETQNA(JA, JB) ! * ! This generates the arrays defining the quantum numbers of the * ! states involved in the matrix element linking configurations * @@ -11,136 +11,136 @@ SUBROUTINE SETQNA(JA, JB) ! Last update: 30 Oct 1987 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE M_C - USE ORB_C, ONLY: NCF, NW + USE ORB_C, ONLY: NCF, NW !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE iq_I - USE jqs_I - USE ichop_I - USE jcup_I + USE iq_I + USE jqs_I + USE ichop_I + USE jcup_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: JA - INTEGER :: JB + INTEGER :: JA + INTEGER :: JB !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J, K, JCNT, JCNTOP, JW1, JW2, JW + INTEGER :: J, K, JCNT, JCNTOP, JW1, JW2, JW !----------------------------------------------- ! ! ! List parameters defining all shells in both configurations, whether ! participating or not ! - DO J = 1, NW - NQ1(J) = IQ(J,JA) - NQ2(J) = IQ(J,JB) - DO K = 1, 3 - JJQ1(K,J) = JQS(K,J,JA) - JJQ2(K,J) = JQS(K,J,JB) - END DO - END DO + DO J = 1, NW + NQ1(J) = IQ(J,JA) + NQ2(J) = IQ(J,JB) + DO K = 1, 3 + JJQ1(K,J) = JQS(K,J,JA) + JJQ2(K,J) = JQS(K,J,JB) + END DO + END DO ! ! Define coupling schemes: set JLIST array to define those shells ! which are open in either configuration, and KLIST array to locate ! the rest. Exclude shells which are empty in both configurations ! - NPEEL = 0 - NCORE = 0 - DO J = 1, NW - IF (ICHOP(J,JA)==(-1) .AND. ICHOP(J,JB)==(-1)) CYCLE - IF (ICHOP(J,JA)==1 .AND. ICHOP(J,JB)==1) THEN - NCORE = NCORE + 1 - KLIST(NCORE) = J - ELSE - NPEEL = NPEEL + 1 - JLIST(NPEEL) = J - ENDIF - END DO + NPEEL = 0 + NCORE = 0 + DO J = 1, NW + IF (ICHOP(J,JA)==(-1) .AND. ICHOP(J,JB)==(-1)) CYCLE + IF (ICHOP(J,JA)==1 .AND. ICHOP(J,JB)==1) THEN + NCORE = NCORE + 1 + KLIST(NCORE) = J + ELSE + NPEEL = NPEEL + 1 + JLIST(NPEEL) = J + ENDIF + END DO ! ! Return if not more than one shell is open ! - IF (NPEEL <= 1) RETURN + IF (NPEEL <= 1) RETURN ! ! Set arrays of coupling angular momenta interpolating closed ! shells where necessary. Left hand side first ... ! - JCNT = 1 - JCNTOP = 0 - JW1 = JLIST(1) - JW2 = JLIST(2) - IF (ICHOP(JW1,JA) /= 0) THEN - JJC1(1) = JQS(3,JW2,JA) - IF (ICHOP(JW2,JA) == 0) JCNTOP = 1 - ELSE - JCNTOP = 1 - IF (ICHOP(JW2,JA) == 0) THEN - JJC1(1) = JCUP(JCNT,JA) - JCNT = JCNT + 1 - ELSE - JJC1(1) = JQS(3,JW1,JA) - ENDIF - ENDIF + JCNT = 1 + JCNTOP = 0 + JW1 = JLIST(1) + JW2 = JLIST(2) + IF (ICHOP(JW1,JA) /= 0) THEN + JJC1(1) = JQS(3,JW2,JA) + IF (ICHOP(JW2,JA) == 0) JCNTOP = 1 + ELSE + JCNTOP = 1 + IF (ICHOP(JW2,JA) == 0) THEN + JJC1(1) = JCUP(JCNT,JA) + JCNT = JCNT + 1 + ELSE + JJC1(1) = JQS(3,JW1,JA) + ENDIF + ENDIF ! - DO J = 3, NPEEL - JW = JLIST(J) - IF (ICHOP(JW,JA) /= 0) THEN - JJC1(J-1) = JJC1(J-2) - ELSE - IF (JCNTOP /= 0) THEN - JJC1(J-1) = JCUP(JCNT,JA) - JCNT = JCNT + 1 - ELSE - JJC1(J-1) = JQS(3,JW,JA) - ENDIF - JCNTOP = JCNTOP + 1 - ENDIF - END DO + DO J = 3, NPEEL + JW = JLIST(J) + IF (ICHOP(JW,JA) /= 0) THEN + JJC1(J-1) = JJC1(J-2) + ELSE + IF (JCNTOP /= 0) THEN + JJC1(J-1) = JCUP(JCNT,JA) + JCNT = JCNT + 1 + ELSE + JJC1(J-1) = JQS(3,JW,JA) + ENDIF + JCNTOP = JCNTOP + 1 + ENDIF + END DO ! ! ... and repeat for right hand side ! - JCNT = 1 - JCNTOP = 0 - JW1 = JLIST(1) - JW2 = JLIST(2) - IF (ICHOP(JW1,JB) /= 0) THEN - JJC2(1) = JQS(3,JW2,JB) - IF (ICHOP(JW2,JB) == 0) JCNTOP = 1 - ELSE - JCNTOP = 1 - IF (ICHOP(JW2,JB) == 0) THEN - JJC2(1) = JCUP(JCNT,JB) - JCNT = JCNT + 1 - ELSE - JJC2(1) = JQS(3,JW1,JB) - ENDIF - ENDIF + JCNT = 1 + JCNTOP = 0 + JW1 = JLIST(1) + JW2 = JLIST(2) + IF (ICHOP(JW1,JB) /= 0) THEN + JJC2(1) = JQS(3,JW2,JB) + IF (ICHOP(JW2,JB) == 0) JCNTOP = 1 + ELSE + JCNTOP = 1 + IF (ICHOP(JW2,JB) == 0) THEN + JJC2(1) = JCUP(JCNT,JB) + JCNT = JCNT + 1 + ELSE + JJC2(1) = JQS(3,JW1,JB) + ENDIF + ENDIF ! - DO J = 3, NPEEL - JW = JLIST(J) - IF (ICHOP(JW,JB) /= 0) THEN - JJC2(J-1) = JJC2(J-2) - ELSE - IF (JCNTOP /= 0) THEN - JJC2(J-1) = JCUP(JCNT,JB) - JCNT = JCNT + 1 - ELSE - JJC2(J-1) = JQS(3,JW,JB) - ENDIF - JCNTOP = JCNTOP + 1 - ENDIF - END DO + DO J = 3, NPEEL + JW = JLIST(J) + IF (ICHOP(JW,JB) /= 0) THEN + JJC2(J-1) = JJC2(J-2) + ELSE + IF (JCNTOP /= 0) THEN + JJC2(J-1) = JCUP(JCNT,JB) + JCNT = JCNT + 1 + ELSE + JJC2(J-1) = JQS(3,JW,JB) + ENDIF + JCNTOP = JCNTOP + 1 + ENDIF + END DO ! - RETURN - END SUBROUTINE SETQNA + RETURN + END SUBROUTINE SETQNA diff --git a/src/lib/lib9290/setqna_I.f90 b/src/lib/lib9290/setqna_I.f90 index e83ea755a..cac98044c 100644 --- a/src/lib/lib9290/setqna_I.f90 +++ b/src/lib/lib9290/setqna_I.f90 @@ -1,17 +1,17 @@ - MODULE setqna_I + MODULE setqna_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:39 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setqna (JA, JB) - INTEGER :: JA - INTEGER :: JB + SUBROUTINE setqna (JA, JB) + INTEGER :: JA + INTEGER :: JB !VAST.../M0/ JJC1(INOUT), JJC2(INOUT) !VAST.../M1/ NQ1(OUT), NQ2(OUT) !VAST.../M2/ JJQ1(OUT), JJQ2(OUT) !VAST.../M3/ JLIST(INOUT), KLIST(OUT), NPEEL(OUT), NCORE(OUT) !VAST.../ORB2/ NW(IN) !VAST...Calls: IQ, JQS, ICHOP, JCUP - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/setrwfa.f90 b/src/lib/lib9290/setrwfa.f90 index d7b13cb30..86fd4e2d3 100644 --- a/src/lib/lib9290/setrwfa.f90 +++ b/src/lib/lib9290/setrwfa.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SETRWFA(NAME) + SUBROUTINE SETRWFA(NAME) ! * ! Open, check, load data from and close the .rwf file. * ! * @@ -10,19 +10,19 @@ SUBROUTINE SETRWFA(NAME) ! Modified by Xinghong He Last revision: 09 Jul 1998 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:42 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:42 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE IOUNIT_C + USE vast_kind_param, ONLY: DOUBLE + USE IOUNIT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE openfl_I - USE lodrwf_I + USE openfl_I + USE lodrwf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s @@ -31,37 +31,37 @@ SUBROUTINE SETRWFA(NAME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IERR, IOS - CHARACTER :: G92RWF*6 + INTEGER :: IERR, IOS + CHARACTER :: G92RWF*6 - CALL OPENFL (23, NAME, 'UNFORMATTED', 'OLD', IERR) - IF (IERR == 1) THEN - WRITE (ISTDE, *) 'Error when opening', NAME(1:LEN_TRIM(NAME)) - STOP - ENDIF + CALL OPENFL (23, NAME, 'UNFORMATTED', 'OLD', IERR) + IF (IERR == 1) THEN + WRITE (ISTDE, *) 'Error when opening', NAME(1:LEN_TRIM(NAME)) + STOP + ENDIF ! ! Check the file; if not as expected, stop. ! - READ (23, IOSTAT=IOS) G92RWF - IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN - WRITE (ISTDE, *) 'This is not a Radial WaveFunction File;' - CLOSE(23) - STOP - ENDIF + READ (23, IOSTAT=IOS) G92RWF + IF (IOS/=0 .OR. G92RWF/='G92RWF') THEN + WRITE (ISTDE, *) 'This is not a Radial WaveFunction File;' + CLOSE(23) + STOP + ENDIF ! ! Attempt to load the radial wavefunctions; if this fails, stop ! - CALL LODRWF (IERR) - - IF (IERR /= 0) THEN + CALL LODRWF (IERR) + + IF (IERR /= 0) THEN WRITE (ISTDE, *) 'Radial wavefunctions defined in CSL file', & - ' not found in Radial WaveFunction File' - CLOSE(23) - STOP - ENDIF - - CLOSE(23) - - RETURN - END SUBROUTINE SETRWFA + ' not found in Radial WaveFunction File' + CLOSE(23) + STOP + ENDIF + + CLOSE(23) + + RETURN + END SUBROUTINE SETRWFA diff --git a/src/lib/lib9290/setrwfa_I.f90 b/src/lib/lib9290/setrwfa_I.f90 index 988c87894..1202faae5 100644 --- a/src/lib/lib9290/setrwfa_I.f90 +++ b/src/lib/lib9290/setrwfa_I.f90 @@ -1,13 +1,13 @@ - MODULE setrwfa_I + MODULE setrwfa_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:42 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:42 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE setrwfa (NAME) - CHARACTER (LEN = *), INTENT(IN) :: NAME + SUBROUTINE setrwfa (NAME) + CHARACTER (LEN = *), INTENT(IN) :: NAME !VAST.../IOUNIT/ ISTDE(IN) !VAST...Calls: OPENFL, LODRWF !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/skrc.f90 b/src/lib/lib9290/skrc.f90 index d98e4c4bd..250f77d64 100644 --- a/src/lib/lib9290/skrc.f90 +++ b/src/lib/lib9290/skrc.f90 @@ -1,23 +1,23 @@ !*********************************************************************** ! * - SUBROUTINE SKRC(IS, KAPS, KS, KD1, KD2, KE1, KE2) + SUBROUTINE SKRC(IS, KAPS, KS, KD1, KD2, KE1, KE2) ! * ! Determines the range of the tensor rank k for Coulomb integral. * ! * ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:43 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:43 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: KD1 - INTEGER, INTENT(OUT) :: KD2 - INTEGER, INTENT(OUT) :: KE1 - INTEGER, INTENT(OUT) :: KE2 + INTEGER, INTENT(OUT) :: KD1 + INTEGER, INTENT(OUT) :: KD2 + INTEGER, INTENT(OUT) :: KE1 + INTEGER, INTENT(OUT) :: KE2 INTEGER, DIMENSION(4), INTENT(IN) :: IS INTEGER, DIMENSION(4), INTENT(IN) :: KAPS INTEGER, DIMENSION(4), INTENT(IN) :: KS @@ -25,52 +25,52 @@ SUBROUTINE SKRC(IS, KAPS, KS, KD1, KD2, KE1, KE2) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: ISD1, ISD2, KD1A, KD1B, KD2A, KD2B, ISE1, ISE2, KE1A, & - KE1B, KE2A, KE2B + KE1B, KE2A, KE2B !----------------------------------------------- ! ! - KD2 = 0 - KE2 = 0 + KD2 = 0 + KE2 = 0 ! ! Direct terms --- KD1 = minimum k , KD2 = number of terms ! - ISD1 = 1 - IF (KAPS(1)*KAPS(3) < 0) ISD1 = -1 - ISD2 = 1 - IF (KAPS(2)*KAPS(4) < 0) ISD2 = -1 - KD1A = ABS(KS(1)-KS(3)) - IF (ISD1 < 0) KD1A = KD1A + 2 - KD1B = ABS(KS(2)-KS(4)) - IF (ISD2 < 0) KD1B = KD1B + 2 - IF (MOD((KD1A - KD1B)/2,2) == 0) THEN - KD2A = KS(1) + KS(3) - 2 - IF (ISD1 > 0) KD2A = KD2A - 2 - KD2B = KS(2) + KS(4) - 2 - IF (ISD2 > 0) KD2B = KD2B - 2 - KD1 = MAX(KD1A,KD1B)/2 - KD2 = MIN(KD2A,KD2B)/2 - KD2 = (KD2 - KD1)/2 + 1 - ENDIF + ISD1 = 1 + IF (KAPS(1)*KAPS(3) < 0) ISD1 = -1 + ISD2 = 1 + IF (KAPS(2)*KAPS(4) < 0) ISD2 = -1 + KD1A = ABS(KS(1)-KS(3)) + IF (ISD1 < 0) KD1A = KD1A + 2 + KD1B = ABS(KS(2)-KS(4)) + IF (ISD2 < 0) KD1B = KD1B + 2 + IF (MOD((KD1A - KD1B)/2,2) == 0) THEN + KD2A = KS(1) + KS(3) - 2 + IF (ISD1 > 0) KD2A = KD2A - 2 + KD2B = KS(2) + KS(4) - 2 + IF (ISD2 > 0) KD2B = KD2B - 2 + KD1 = MAX(KD1A,KD1B)/2 + KD2 = MIN(KD2A,KD2B)/2 + KD2 = (KD2 - KD1)/2 + 1 + ENDIF ! ! Exchange terms --- KE1 = minimum k , KE2 = number of terms ! - IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) RETURN - ISE1 = 1 - IF (KAPS(1)*KAPS(4) < 0) ISE1 = -1 - ISE2 = 1 - IF (KAPS(2)*KAPS(3) < 0) ISE2 = -1 - KE1A = ABS(KS(1)-KS(4)) - IF (ISE1 < 0) KE1A = KE1A + 2 - KE1B = ABS(KS(2)-KS(3)) - IF (ISE2 < 0) KE1B = KE1B + 2 - IF (MOD((KE1A - KE1B)/2,2) /= 0) RETURN - KE2A = KS(1) + KS(4) - 2 - IF (ISE1 > 0) KE2A = KE2A - 2 - KE2B = KS(2) + KS(3) - 2 - IF (ISE2 > 0) KE2B = KE2B - 2 - KE1 = MAX(KE1A,KE1B)/2 - KE2 = MIN(KE2A,KE2B)/2 - KE2 = (KE2 - KE1)/2 + 1 + IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) RETURN + ISE1 = 1 + IF (KAPS(1)*KAPS(4) < 0) ISE1 = -1 + ISE2 = 1 + IF (KAPS(2)*KAPS(3) < 0) ISE2 = -1 + KE1A = ABS(KS(1)-KS(4)) + IF (ISE1 < 0) KE1A = KE1A + 2 + KE1B = ABS(KS(2)-KS(3)) + IF (ISE2 < 0) KE1B = KE1B + 2 + IF (MOD((KE1A - KE1B)/2,2) /= 0) RETURN + KE2A = KS(1) + KS(4) - 2 + IF (ISE1 > 0) KE2A = KE2A - 2 + KE2B = KS(2) + KS(3) - 2 + IF (ISE2 > 0) KE2B = KE2B - 2 + KE1 = MAX(KE1A,KE1B)/2 + KE2 = MIN(KE2A,KE2B)/2 + KE2 = (KE2 - KE1)/2 + 1 ! - RETURN - END SUBROUTINE SKRC + RETURN + END SUBROUTINE SKRC diff --git a/src/lib/lib9290/skrc_I.f90 b/src/lib/lib9290/skrc_I.f90 index 9c2c7fbd0..cd3e4dc39 100644 --- a/src/lib/lib9290/skrc_I.f90 +++ b/src/lib/lib9290/skrc_I.f90 @@ -1,16 +1,16 @@ - MODULE skrc_I + MODULE skrc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:43 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:43 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE skrc (IS, KAPS, KS, KD1, KD2, KE1, KE2) - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, DIMENSION(4), INTENT(IN) :: KS - INTEGER, INTENT(OUT) :: KD1 - INTEGER, INTENT(OUT) :: KD2 - INTEGER, INTENT(OUT) :: KE1 - INTEGER, INTENT(OUT) :: KE2 - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE skrc (IS, KAPS, KS, KD1, KD2, KE1, KE2) + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, DIMENSION(4), INTENT(IN) :: KS + INTEGER, INTENT(OUT) :: KD1 + INTEGER, INTENT(OUT) :: KD2 + INTEGER, INTENT(OUT) :: KE1 + INTEGER, INTENT(OUT) :: KE2 + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/slater.f90 b/src/lib/lib9290/slater.f90 index c45e17dcb..18cefd1f3 100644 --- a/src/lib/lib9290/slater.f90 +++ b/src/lib/lib9290/slater.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - REAL(KIND(0.0D0)) FUNCTION SLATER (IA, IB, IC, ID, K) + REAL(KIND(0.0D0)) FUNCTION SLATER (IA, IB, IC, ID, K) ! * ! The value of this function is the Slater integral * ! * @@ -12,23 +12,23 @@ REAL(KIND(0.0D0)) FUNCTION SLATER (IA, IB, IC, ID, K) ! Last revision: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:44 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:44 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE DEBUG_C - USE GRID_C - USE ORB_C + USE vast_kind_param, ONLY: DOUBLE + USE DEBUG_C + USE GRID_C + USE ORB_C USE TATB_C, ONLY: TA, TB, MTP - USE WAVE_C, ONLY: MF, QF, PF + USE WAVE_C, ONLY: MF, QF, PF !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE yzk_I - USE quad_I + USE yzk_I + USE quad_I IMPLICIT NONE !----------------------------------------------- ! G l o b a l P a r a m e t e r s @@ -36,46 +36,46 @@ REAL(KIND(0.0D0)) FUNCTION SLATER (IA, IB, IC, ID, K) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IA - INTEGER :: IB - INTEGER :: IC - INTEGER :: ID - INTEGER :: K + INTEGER :: IA + INTEGER :: IB + INTEGER :: IC + INTEGER :: ID + INTEGER :: K !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I - REAL(DOUBLE) :: RESULT + INTEGER :: I + REAL(DOUBLE) :: RESULT !----------------------------------------------- ! ! - CALL YZK (K, IB, ID) + CALL YZK (K, IB, ID) ! ! Multiply by second term, and obtain result by integration ! - IF (K==0 .AND. IB==ID) THEN - MTP = MIN(MF(IA),MF(IC)) - ELSE - MTP = MIN(MIN(MTP,MF(IA)),MF(IC)) - ENDIF + IF (K==0 .AND. IB==ID) THEN + MTP = MIN(MF(IA),MF(IC)) + ELSE + MTP = MIN(MIN(MTP,MF(IA)),MF(IC)) + ENDIF ! - TA(1) = 0.0D00 - DO I = 2, MTP - TA(I) = (PF(I,IA)*PF(I,IC) + QF(I,IA)*QF(I,IC))*RPOR(I)*TB(I) - END DO + TA(1) = 0.0D00 + DO I = 2, MTP + TA(I) = (PF(I,IA)*PF(I,IC) + QF(I,IA)*QF(I,IC))*RPOR(I)*TB(I) + END DO ! - CALL QUAD (RESULT) - SLATER = RESULT + CALL QUAD (RESULT) + SLATER = RESULT ! ! Debug printout ! IF (LDBPR(10)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IB), NH(IB), NP(IC)& - , NH(IC), NP(ID), NH(ID), SLATER + , NH(IC), NP(ID), NH(ID), SLATER ! - RETURN + RETURN ! 300 FORMAT(/,' (',1I1,')',/,' R (',1I2,1A2,',',1I2,1A2,';',1I2,1A2,',',1I2& - ,1A2,') ','= ',1P,D19.12) - RETURN + ,1A2,') ','= ',1P,D19.12) + RETURN ! - END FUNCTION SLATER + END FUNCTION SLATER diff --git a/src/lib/lib9290/slater_I.f90 b/src/lib/lib9290/slater_I.f90 index 2db19b8ea..4ae062a0a 100644 --- a/src/lib/lib9290/slater_I.f90 +++ b/src/lib/lib9290/slater_I.f90 @@ -1,14 +1,14 @@ - MODULE slater_I + MODULE slater_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:44 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:44 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(KIND(0.0D0)) FUNCTION slater (IA, IB, IC, ID, K) - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: K + REAL(KIND(0.0D0)) FUNCTION slater (IA, IB, IC, ID, K) + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: K !VAST.../DEBUGR/ LDBPR(IN) !VAST.../GRID/ RPOR(IN) !VAST.../ORB4/ NP(IN) @@ -17,6 +17,6 @@ REAL(KIND(0.0D0)) FUNCTION slater (IA, IB, IC, ID, K) !VAST.../WAVE/ MF(IN) !VAST...Calls: YZK, PF, QF, QUAD !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/speak.f90 b/src/lib/lib9290/speak.f90 index 1380df1cb..35b9eb8ec 100644 --- a/src/lib/lib9290/speak.f90 +++ b/src/lib/lib9290/speak.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SPEAK(JA, JB, IA1, IB1, IA2, IB2, K, X) + SUBROUTINE SPEAK(JA, JB, IA1, IB1, IA2, IB2, K, X) ! * ! Output MCP coefficients and integral parameters to COMMON block * ! /BUFFER/. Also print these if IBUG1 = 1 . * @@ -8,59 +8,59 @@ SUBROUTINE SPEAK(JA, JB, IA1, IB1, IA2, IB2, K, X) ! Last Update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:59:36 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:59:36 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE BUFFER_C, ONLY: LABEL, COEFF, NBDIM, NVCOEF USE DEBUG_C , ONLY: IBUG1 - USE ORB_C, ONLY: NP, NH + USE ORB_C, ONLY: NP, NH ! !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcbuf_I + USE alcbuf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: IA1 - INTEGER, INTENT(IN) :: IB1 - INTEGER, INTENT(IN) :: IA2 - INTEGER, INTENT(IN) :: IB2 - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(IN) :: X + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: IA1 + INTEGER, INTENT(IN) :: IB1 + INTEGER, INTENT(IN) :: IA2 + INTEGER, INTENT(IN) :: IB2 + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(IN) :: X !----------------------------------------------- ! ! IF (IBUG1 /= 0) WRITE (99, 300) JA, JB, NP(IA1), NH(IA1), NP(IB1), NH(IB1& - ), NP(IA2), NH(IA2), NP(IB2), NH(IB2), K, X + ), NP(IA2), NH(IA2), NP(IB2), NH(IB2), K, X ! ! Increment counter ! - NVCOEF = NVCOEF + 1 + NVCOEF = NVCOEF + 1 ! ! Ensure that arrays are of adequate size; reallocate if necessary ! - IF (NVCOEF > NBDIM) CALL ALCBUF (2) + IF (NVCOEF > NBDIM) CALL ALCBUF (2) ! ! Store integral indices and coefficient in COMMON/BUFFER/ ! - LABEL(1,NVCOEF) = IA1 - LABEL(2,NVCOEF) = IB1 - LABEL(3,NVCOEF) = IA2 - LABEL(4,NVCOEF) = IB2 - LABEL(5,NVCOEF) = K - COEFF(NVCOEF) = X + LABEL(1,NVCOEF) = IA1 + LABEL(2,NVCOEF) = IB1 + LABEL(3,NVCOEF) = IA2 + LABEL(4,NVCOEF) = IB2 + LABEL(5,NVCOEF) = K + COEFF(NVCOEF) = X ! - RETURN + RETURN ! - 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,I2,1X,1P,D19.12) - RETURN + 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,I2,1X,1P,D19.12) + RETURN ! - END SUBROUTINE SPEAK + END SUBROUTINE SPEAK diff --git a/src/lib/lib9290/speak_I.f90 b/src/lib/lib9290/speak_I.f90 index 4088c7d5d..fa1635453 100644 --- a/src/lib/lib9290/speak_I.f90 +++ b/src/lib/lib9290/speak_I.f90 @@ -1,24 +1,24 @@ - MODULE speak_I + MODULE speak_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:59:36 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:59:36 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE speak (JA, JB, IA1, IB1, IA2, IB2, K, X) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: IA1 - INTEGER, INTENT(IN) :: IB1 - INTEGER, INTENT(IN) :: IA2 - INTEGER, INTENT(IN) :: IB2 - INTEGER, INTENT(IN) :: K - REAL(DOUBLE), INTENT(IN) :: X + SUBROUTINE speak (JA, JB, IA1, IB1, IA2, IB2, K, X) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: IA1 + INTEGER, INTENT(IN) :: IB1 + INTEGER, INTENT(IN) :: IA2 + INTEGER, INTENT(IN) :: IB2 + INTEGER, INTENT(IN) :: K + REAL(DOUBLE), INTENT(IN) :: X !VAST.../BUFFER/ NBDIM(IN), NVCOEF(INOUT) !VAST.../DEBUG/ IBUG1(IN) !VAST.../ORB4/ NP(IN) !VAST.../ORB10/ NH(IN) !VAST...Calls: ALCBUF !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/spicmv2.f90 b/src/lib/lib9290/spicmv2.f90 index 25381be10..37819792d 100644 --- a/src/lib/lib9290/spicmv2.f90 +++ b/src/lib/lib9290/spicmv2.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - SUBROUTINE SPICMV2(N, M, B, C) + SUBROUTINE SPICMV2(N, M, B, C) ! ! Modified from the mpi version spicmvmpi.f by simply removing things ! required by mpi communication. @@ -7,54 +7,54 @@ SUBROUTINE SPICMV2(N, M, B, C) ! Xinghong He 98-07-29 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:47 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:47 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE HMAT_C + USE vast_kind_param, ONLY: DOUBLE + USE HMAT_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE dinit_I -! USE dmerge_I + USE dinit_I +! USE dmerge_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: IBEG, ICOL, IEND, NELC, IV - REAL(DOUBLE) :: DIAG, DL + REAL(DOUBLE) :: DIAG, DL !----------------------------------------------- ! ! ! Initialise the result matrix; note that this is specific to the ! data structure of DVDSON --- no overdimensioning ! - CALL DINIT (N*M, 0.D0, C, 1) - - IBEG = 1 - DO ICOL = 1, N + CALL DINIT (N*M, 0.D0, C, 1) + + IBEG = 1 + DO ICOL = 1, N !IBEG = IENDC(ICOL-1)+1 !IEND = IENDC(ICOL) - IEND = IENDC(ICOL) - NELC = IEND - IBEG + 1 - DO IV = 1, M - DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) + IEND = IENDC(ICOL) + NELC = IEND - IBEG + 1 + DO IV = 1, M + DIAG = C(ICOL,IV) + EMT(IEND)*B(ICOL,IV) CALL DMERGE (NELC-1, B(:N,IV), C(:N,IV), IROW(IBEG), EMT(IBEG), B(& ICOL,IV), DL) - C(ICOL,IV) = DIAG + DL - END DO - IBEG = IEND + 1 - END DO - - RETURN - END SUBROUTINE SPICMV2 + C(ICOL,IV) = DIAG + DL + END DO + IBEG = IEND + 1 + END DO + + RETURN + END SUBROUTINE SPICMV2 diff --git a/src/lib/lib9290/spicmv2_I.f90 b/src/lib/lib9290/spicmv2_I.f90 index 4cf3b46ba..d65aee062 100644 --- a/src/lib/lib9290/spicmv2_I.f90 +++ b/src/lib/lib9290/spicmv2_I.f90 @@ -1,15 +1,15 @@ - MODULE spicmv2_I + MODULE spicmv2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:47 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:47 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spicmv2 (N, M, B, C) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + SUBROUTINE spicmv2 (N, M, B, C) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C !VAST...Calls: DINIT, IENDC, EMT, DMERGE, IROW - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/start.f90 b/src/lib/lib9290/start.f90 index 96d35a434..cb697bf78 100644 --- a/src/lib/lib9290/start.f90 +++ b/src/lib/lib9290/start.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE START(IORB, ITYPE, P0, P, Q0, Q) + SUBROUTINE START(IORB, ITYPE, P0, P, Q0, Q) ! * ! This subroutine sets up P(1:6), Q(1:6), required to start the * ! integration for programs OUT and SBSTEP . * @@ -18,191 +18,191 @@ SUBROUTINE START(IORB, ITYPE, P0, P, Q0, Q) ! Written by Farid A Parpia, at Oxford Last update: 09 Dec 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:48 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:48 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP - USE CNC_C + USE CNC_C USE DEF_C, ONLY: C, Z, ACCY - USE GRID_C - USE NPAR_C - USE ORB_C - USE POTE_C, ONLY: YP, XP, XQ + USE GRID_C + USE NPAR_C + USE ORB_C + USE POTE_C, ONLY: YP, XP, XQ USE SCF_C, ONLY: NDCOF, NDA, DA - USE WAVE_C, ONLY: PZ,PF,QF + USE WAVE_C, ONLY: PZ,PF,QF IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IORB - INTEGER, INTENT(IN) :: ITYPE - REAL(DOUBLE), INTENT(IN) :: P0 - REAL(DOUBLE), INTENT(OUT) :: Q0 + INTEGER :: IORB + INTEGER, INTENT(IN) :: ITYPE + REAL(DOUBLE), INTENT(IN) :: P0 + REAL(DOUBLE), INTENT(OUT) :: Q0 REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: MXITER=36, KIORB, I, JORB, NITER, J - REAL(DOUBLE), DIMENSION(6) :: RDP, RDQ, RSEP, RSEQ - REAL(DOUBLE), DIMENSION(2:6) :: SPEST, SQEST + INTEGER :: MXITER=36, KIORB, I, JORB, NITER, J + REAL(DOUBLE), DIMENSION(6) :: RDP, RDQ, RSEP, RSEQ + REAL(DOUBLE), DIMENSION(2:6) :: SPEST, SQEST REAL(DOUBLE) :: OBC, ZONC, GIORB, FKIORB, OMGI, OMGMK, OMGPK, RSEP1, & RSEQ1, PZERO, P1, Q1, SUMP, SUMQ, FACTOR, CSQ, TWOCSQ, ENERGY, ENEFAC& - , RI, RPI, RIRPI, YPIRPI, DIFMAW, DIFMAX, COEFIJ, PI, QI, RJ + , RI, RPI, RIRPI, YPIRPI, DIFMAW, DIFMAX, COEFIJ, PI, QI, RJ !----------------------------------------------- ! ! ! Initialization ! - OBC = 1.0D00/C - ZONC = Z*OBC - GIORB = GAMA(IORB) - KIORB = NAK(IORB) - FKIORB = DBLE(KIORB) - OMGI = 1.0D00 - GIORB + OBC = 1.0D00/C + ZONC = Z*OBC + GIORB = GAMA(IORB) + KIORB = NAK(IORB) + FKIORB = DBLE(KIORB) + OMGI = 1.0D00 - GIORB ! - OMGMK = OMGI - FKIORB - OMGPK = OMGI + FKIORB + OMGMK = OMGI - FKIORB + OMGPK = OMGI + FKIORB ! ! Determine P(1), Q(1): THESE STORE R**(-GAMMA)*(P(1),Q(1)); ! set up RSEP and RSEQ , the inhomogeneous terms ! - IF (ITYPE==1 .OR. ITYPE==2) THEN - IF (NPARM == 0) THEN - P(1) = P0 - IF (KIORB < 0) THEN - Q(1) = -P0*ZONC/(GIORB - FKIORB) - ELSE - Q(1) = P0*(GIORB + FKIORB)/ZONC - ENDIF - ELSE - IF (KIORB < 0) THEN - P(1) = P0 - Q(1) = 0.0D00 - ELSE - P(1) = 0.0D00 - Q(1) = P0*(GIORB + FKIORB)/ZONC - ENDIF - ENDIF - IF (ITYPE == 1) THEN - RSEP = 0.0D00 - RSEQ = 0.0D00 - ELSE - RSEP1 = 0.0D00 - RSEQ1 = 0.0D00 - DO I = 1, NDCOF - JORB = NDA(I) - PZERO = PZ(JORB) - IF (NPARM == 0) THEN - P1 = PZERO - IF (KIORB < 0) THEN - Q1 = -PZERO*ZONC/(GIORB - FKIORB) - ELSE - Q1 = PZERO*(GIORB + FKIORB)/ZONC - ENDIF - SUMP = ZONC*Q1 - SUMQ = -ZONC*P1 - ELSE - IF (KIORB < 0) THEN - P1 = PZERO - Q1 = 0.0D00 - ELSE - P1 = 0.0D00 - Q1 = PZERO*(GIORB + FKIORB)/ZONC - ENDIF - SUMP = 0.0D00 - SUMQ = 0.0D00 - ENDIF - FACTOR = DA(I) - RSEP1 = RSEP1 + FACTOR*(SUMP + OMGMK*P1) - RSEQ1 = RSEQ1 + FACTOR*(SUMQ + OMGPK*Q1) - END DO - FACTOR = RP(1) - RSEP(1) = FACTOR*RSEP1 - RSEQ(1) = FACTOR*RSEQ1 - DO I = 2, 6 - FACTOR = -RP(I)*R(I)**(-GIORB) - RSEP(I) = FACTOR*XP(I) - RSEQ(I) = FACTOR*XQ(I) - END DO - ENDIF - ELSE IF (ITYPE == 3) THEN - P(1) = 0.0D00 - Q(1) = 0.0D00 - RSEP(1) = 0.0D00 - RSEQ(1) = 0.0D00 - DO I = 2, 6 - FACTOR = OBC*RP(I)*R(I)**OMGI - RSEP(I) = -FACTOR*QF(I,IORB) - RSEQ(I) = FACTOR*PF(I,IORB) - END DO - ENDIF - Q0 = Q(1) + IF (ITYPE==1 .OR. ITYPE==2) THEN + IF (NPARM == 0) THEN + P(1) = P0 + IF (KIORB < 0) THEN + Q(1) = -P0*ZONC/(GIORB - FKIORB) + ELSE + Q(1) = P0*(GIORB + FKIORB)/ZONC + ENDIF + ELSE + IF (KIORB < 0) THEN + P(1) = P0 + Q(1) = 0.0D00 + ELSE + P(1) = 0.0D00 + Q(1) = P0*(GIORB + FKIORB)/ZONC + ENDIF + ENDIF + IF (ITYPE == 1) THEN + RSEP = 0.0D00 + RSEQ = 0.0D00 + ELSE + RSEP1 = 0.0D00 + RSEQ1 = 0.0D00 + DO I = 1, NDCOF + JORB = NDA(I) + PZERO = PZ(JORB) + IF (NPARM == 0) THEN + P1 = PZERO + IF (KIORB < 0) THEN + Q1 = -PZERO*ZONC/(GIORB - FKIORB) + ELSE + Q1 = PZERO*(GIORB + FKIORB)/ZONC + ENDIF + SUMP = ZONC*Q1 + SUMQ = -ZONC*P1 + ELSE + IF (KIORB < 0) THEN + P1 = PZERO + Q1 = 0.0D00 + ELSE + P1 = 0.0D00 + Q1 = PZERO*(GIORB + FKIORB)/ZONC + ENDIF + SUMP = 0.0D00 + SUMQ = 0.0D00 + ENDIF + FACTOR = DA(I) + RSEP1 = RSEP1 + FACTOR*(SUMP + OMGMK*P1) + RSEQ1 = RSEQ1 + FACTOR*(SUMQ + OMGPK*Q1) + END DO + FACTOR = RP(1) + RSEP(1) = FACTOR*RSEP1 + RSEQ(1) = FACTOR*RSEQ1 + DO I = 2, 6 + FACTOR = -RP(I)*R(I)**(-GIORB) + RSEP(I) = FACTOR*XP(I) + RSEQ(I) = FACTOR*XQ(I) + END DO + ENDIF + ELSE IF (ITYPE == 3) THEN + P(1) = 0.0D00 + Q(1) = 0.0D00 + RSEP(1) = 0.0D00 + RSEQ(1) = 0.0D00 + DO I = 2, 6 + FACTOR = OBC*RP(I)*R(I)**OMGI + RSEP(I) = -FACTOR*QF(I,IORB) + RSEQ(I) = FACTOR*PF(I,IORB) + END DO + ENDIF + Q0 = Q(1) ! ! Set up RDP and RDQ ! - CSQ = C*C - TWOCSQ = CSQ + CSQ - ENERGY = E(IORB) - ENEFAC = TWOCSQ - ENERGY - DO I = 1, 6 - RI = R(I) - RPI = RP(I) - RIRPI = RI*RPI - YPIRPI = YP(I)*RPI - RDP(I) = -OBC*(ENEFAC*RIRPI + YPIRPI) - RDQ(I) = -OBC*(ENERGY*RIRPI - YPIRPI) - END DO + CSQ = C*C + TWOCSQ = CSQ + CSQ + ENERGY = E(IORB) + ENEFAC = TWOCSQ - ENERGY + DO I = 1, 6 + RI = R(I) + RPI = RP(I) + RIRPI = RI*RPI + YPIRPI = YP(I)*RPI + RDP(I) = -OBC*(ENEFAC*RIRPI + YPIRPI) + RDQ(I) = -OBC*(ENERGY*RIRPI - YPIRPI) + END DO ! ! Determine P(2:6) , Q(2:6) ! ! Initilizations for the iterations ! - NITER = 0 - P1 = P(1) - Q1 = Q(1) - DIFMAW = MAX(ABS(P1),ABS(Q1)) + NITER = 0 + P1 = P(1) + Q1 = Q(1) + DIFMAW = MAX(ABS(P1),ABS(Q1)) ! - P(2:6) = P1 - Q(2:6) = Q1 + P(2:6) = P1 + Q(2:6) = Q1 ! ! This is the largest factor by which any result will be ! multiplied ! - FACTOR = R(6)**GIORB + FACTOR = R(6)**GIORB ! ! Now iterate ! - 7 CONTINUE - NITER = NITER + 1 - DIFMAX = 0.0D00 - DO J = 2, 6 - SUMP = SUM(CNC6C(:,J)*(OMGMK*RP(:6)*P(:6)-RDP*Q(:6)+RSEP)) - SUMQ = SUM(CNC6C(:,J)*(OMGPK*RP(:6)*Q(:6)-RDQ*P(:6)+RSEQ)) - RJ = R(J) - SUMP = SUMP/RJ - SUMQ = SUMQ/RJ - SPEST(J) = SUMP - SQEST(J) = SUMQ - DIFMAX = MAX(DIFMAX,ABS(SUMP - P(J))) - DIFMAX = MAX(DIFMAX,ABS(SUMQ - Q(J))) - END DO + 7 CONTINUE + NITER = NITER + 1 + DIFMAX = 0.0D00 + DO J = 2, 6 + SUMP = SUM(CNC6C(:,J)*(OMGMK*RP(:6)*P(:6)-RDP*Q(:6)+RSEP)) + SUMQ = SUM(CNC6C(:,J)*(OMGPK*RP(:6)*Q(:6)-RDQ*P(:6)+RSEQ)) + RJ = R(J) + SUMP = SUMP/RJ + SUMQ = SUMQ/RJ + SPEST(J) = SUMP + SQEST(J) = SUMQ + DIFMAX = MAX(DIFMAX,ABS(SUMP - P(J))) + DIFMAX = MAX(DIFMAX,ABS(SUMQ - Q(J))) + END DO !zou IF (DIFMAX .LT. DIFMAW) THEN - P(2:6) = SPEST(:6) - Q(2:6) = SQEST(:6) - DIFMAW = DIFMAX - DIFMAX = DIFMAX*FACTOR - IF (DIFMAX > ACCY) THEN - IF (NITER < MXITER) THEN - GO TO 7 - ELSE - WRITE (*, 300) NP(IORB), NH(IORB), DIFMAX, NITER, ACCY - ENDIF - ENDIF + P(2:6) = SPEST(:6) + Q(2:6) = SQEST(:6) + DIFMAW = DIFMAX + DIFMAX = DIFMAX*FACTOR + IF (DIFMAX > ACCY) THEN + IF (NITER < MXITER) THEN + GO TO 7 + ELSE + WRITE (*, 300) NP(IORB), NH(IORB), DIFMAX, NITER, ACCY + ENDIF + ENDIF ! ELSE ! DIFMAX = DIFMAX*FACTOR ! IF (DIFMAX .GT. ACCY) THEN @@ -210,30 +210,30 @@ SUBROUTINE START(IORB, ITYPE, P0, P, Q0, Q) ! ENDIF !zou ENDIF ! not convergent, using the initial P,Q - IF (DIFMAX > ACCY) THEN - P(2:6) = P1 - Q(2:6) = Q1 - ENDIF + IF (DIFMAX > ACCY) THEN + P(2:6) = P1 + Q(2:6) = Q1 + ENDIF !zou ! ! All done ! ! This is always true in GRASP2 ! - P(1) = 0.0D00 - Q(1) = 0.0D00 + P(1) = 0.0D00 + Q(1) = 0.0D00 ! - DO I = 2, 6 - FACTOR = R(I)**GIORB - P(I) = FACTOR*P(I) - Q(I) = FACTOR*Q(I) - END DO + DO I = 2, 6 + FACTOR = R(I)**GIORB + P(I) = FACTOR*P(I) + Q(I) = FACTOR*Q(I) + END DO ! - RETURN + RETURN ! 300 FORMAT('START: ',1I2,1A2,' subshell: accuracy ',1P,1D8.1,/,& ' attained after ',1I2,' iterations; this fails the'/,& - ' accuracy criterion ',D8.1,'.') - RETURN + ' accuracy criterion ',D8.1,'.') + RETURN ! - END SUBROUTINE START + END SUBROUTINE START diff --git a/src/lib/lib9290/start_I.f90 b/src/lib/lib9290/start_I.f90 index 328f93ce6..37bc7bc0a 100644 --- a/src/lib/lib9290/start_I.f90 +++ b/src/lib/lib9290/start_I.f90 @@ -1,17 +1,17 @@ - MODULE start_I + MODULE start_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:48 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:48 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE start (IORB, ITYPE, P0, P, Q0, Q) - USE vast_kind_param,ONLY: DOUBLE + SUBROUTINE start (IORB, ITYPE, P0, P, Q0, Q) + USE vast_kind_param,ONLY: DOUBLE USE parameter_def, ONLY: NNNP - INTEGER, INTENT(IN) :: IORB - INTEGER, INTENT(IN) :: ITYPE - REAL(DOUBLE), INTENT(IN) :: P0 - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P - REAL(DOUBLE), INTENT(OUT) :: Q0 - REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q + INTEGER, INTENT(IN) :: IORB + INTEGER, INTENT(IN) :: ITYPE + REAL(DOUBLE), INTENT(IN) :: P0 + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: P + REAL(DOUBLE), INTENT(OUT) :: Q0 + REAL(DOUBLE), DIMENSION(NNNP), INTENT(INOUT) :: Q !VAST.../CNC6/ CNC6C(IN) !VAST.../DEF1/ Z(IN) !VAST.../DEF2/ C(IN) @@ -26,6 +26,6 @@ SUBROUTINE start (IORB, ITYPE, P0, P, Q0, Q) !VAST.../WAVE/ PZ(IN) !VAST...Calls: NDA, DA, QF, PF !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/starttime.f90 b/src/lib/lib9290/starttime.f90 index 164d68c35..31a8f10a3 100644 --- a/src/lib/lib9290/starttime.f90 +++ b/src/lib/lib9290/starttime.f90 @@ -1,7 +1,7 @@ !*********************************************************************** - subroutine starttime(ncount1, progname) -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:49 2/14/04 -!...Modified by Charlotte Froese Fischer + subroutine starttime(ncount1, progname) +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:49 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -10,14 +10,14 @@ subroutine starttime(ncount1, progname) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: ncount1 + integer :: ncount1 CHARACTER (LEN = *), INTENT(IN) :: PROGNAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer, dimension(8) :: nymduhmsm - integer :: ncount_rate, ncount_max - character :: chdate*8, chtime*10, chzone*5, msg*80 + integer, dimension(8) :: nymduhmsm + integer :: ncount_rate, ncount_max + character :: chdate*8, chtime*10, chzone*5, msg*80 !----------------------------------------------- ! ! Calls DATE_AND_TIME to get date, time, zone; @@ -28,28 +28,28 @@ subroutine starttime(ncount1, progname) ! ! ! For printing - -! write (6, *) '====================================================' -! write (6, *) ' ', progname, ': Execution Begins ...' -! write (6, *) '====================================================' - + +! write (6, *) '====================================================' +! write (6, *) ' ', progname, ': Execution Begins ...' +! write (6, *) '====================================================' + !======================================================================= ! Get date, time, zone and print !======================================================================= - -!GG call date_and_time (chdate, chtime, chzone, nymduhmsm) -!GG write (6, *) 'Date and Time:' + +!GG call date_and_time (chdate, chtime, chzone, nymduhmsm) +!GG write (6, *) 'Date and Time:' !GG Print*, ' Date (Yr/Mon/Day): ', & !GG chdate(1:4),'/',chdate(5:6),'/',chdate(7:8) !GG Print*, ' Time (Hr/Min/Sec): ', & !GG chtime(1:2),'/',chtime(3:4),'/',chtime(5:10) !GG Print*, ' Zone: ',chzone - + !======================================================================= ! Start timing - Record the wall clock !======================================================================= - - call system_clock (ncount1, ncount_rate, ncount_max) - - return - end subroutine starttime + + call system_clock (ncount1, ncount_rate, ncount_max) + + return + end subroutine starttime diff --git a/src/lib/lib9290/starttime_I.f90 b/src/lib/lib9290/starttime_I.f90 index a56219844..a0fec0ee2 100644 --- a/src/lib/lib9290/starttime_I.f90 +++ b/src/lib/lib9290/starttime_I.f90 @@ -1,13 +1,13 @@ - MODULE starttime_I + MODULE starttime_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:49 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:49 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE starttime (NCOUNT1, PROGNAME) - INTEGER :: NCOUNT1 - CHARACTER (LEN = *), INTENT(IN) :: PROGNAME + SUBROUTINE starttime (NCOUNT1, PROGNAME) + INTEGER :: NCOUNT1 + CHARACTER (LEN = *), INTENT(IN) :: PROGNAME !VAST...Calls: DATE_AND_TIME, SYSTEM_CLOCK !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/stoptime.f90 b/src/lib/lib9290/stoptime.f90 index dc7fd1629..8d8cdb13c 100644 --- a/src/lib/lib9290/stoptime.f90 +++ b/src/lib/lib9290/stoptime.f90 @@ -1,5 +1,5 @@ !*********************************************************************** - subroutine stoptime(ncount1, progname) + subroutine stoptime(ncount1, progname) ! ! Calls DATE_AND_TIME to get date, time, zone; ! @@ -9,8 +9,8 @@ subroutine stoptime(ncount1, progname) ! ! For printing !************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:50 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:50:50 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -19,46 +19,46 @@ subroutine stoptime(ncount1, progname) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer , intent(in) :: ncount1 + integer , intent(in) :: ncount1 CHARACTER (LEN = *), INTENT(IN) :: PROGNAME !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: ncount2, ncount_rate, ncount_max, nseconds - integer, dimension(8) :: nymduhmsm - character :: chdate*8, chtime*10, chzone*5, str2nds*8, msg*80 + integer :: ncount2, ncount_rate, ncount_max, nseconds + integer, dimension(8) :: nymduhmsm + character :: chdate*8, chtime*10, chzone*5, str2nds*8, msg*80 !----------------------------------------------- - + !======================================================================= ! Get processor info: myid, nprocs, host name; and print !======================================================================= - -! write (6, *) '====================================================' -! write (6, *) ' ', progname, ': Execution Finished ...' -! write (6, *) '====================================================' - write (6, *) - write (6, *) 'Wall time:' - - call system_clock (ncount2, ncount_rate, ncount_max) - ncount2 = ncount2 - ncount1 - nseconds = ncount2/ncount_rate - write (str2nds, '(I8)') nseconds - msg = str2nds//' seconds' - write (6, *) msg(1:len_trim(msg)) - - write (6, *) - write (6, *) 'Finish Date and Time:' - - call date_and_time (chdate, chtime, chzone, nymduhmsm) - + +! write (6, *) '====================================================' +! write (6, *) ' ', progname, ': Execution Finished ...' +! write (6, *) '====================================================' + write (6, *) + write (6, *) 'Wall time:' + + call system_clock (ncount2, ncount_rate, ncount_max) + ncount2 = ncount2 - ncount1 + nseconds = ncount2/ncount_rate + write (str2nds, '(I8)') nseconds + msg = str2nds//' seconds' + write (6, *) msg(1:len_trim(msg)) + + write (6, *) + write (6, *) 'Finish Date and Time:' + + call date_and_time (chdate, chtime, chzone, nymduhmsm) + Print*, ' Date (Yr/Mon/Day): ', & chdate(1:4),'/',chdate(5:6),'/',chdate(7:8) Print*, ' Time (Hr/Min/Sec): ', & chtime(1:2),'/',chtime(3:4),'/',chtime(5:10) - Print*, ' Zone: ',chzone - - write (6, *) - write (6, *) progname//': Execution complete.' - - return - end subroutine stoptime + Print*, ' Zone: ',chzone + + write (6, *) + write (6, *) progname//': Execution complete.' + + return + end subroutine stoptime diff --git a/src/lib/lib9290/stoptime_I.f90 b/src/lib/lib9290/stoptime_I.f90 index d2360d17a..9c5b3ca3b 100644 --- a/src/lib/lib9290/stoptime_I.f90 +++ b/src/lib/lib9290/stoptime_I.f90 @@ -1,13 +1,13 @@ - MODULE stoptime_I + MODULE stoptime_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:50 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:50 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE stoptime (NCOUNT1, PROGNAME) - INTEGER, INTENT(IN) :: NCOUNT1 - CHARACTER (LEN = *), INTENT(IN) :: PROGNAME + SUBROUTINE stoptime (NCOUNT1, PROGNAME) + INTEGER, INTENT(IN) :: NCOUNT1 + CHARACTER (LEN = *), INTENT(IN) :: PROGNAME !VAST...Calls: SYSTEM_CLOCK, DATE_AND_TIME !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/lib9290/yzk.f90 b/src/lib/lib9290/yzk.f90 index 39362eca6..add6726db 100644 --- a/src/lib/lib9290/yzk.f90 +++ b/src/lib/lib9290/yzk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE YZK(K, I, J) + SUBROUTINE YZK(K, I, J) ! * ! This subroutine evaluates Hartree Y- and Z-functions: * ! * @@ -27,19 +27,19 @@ SUBROUTINE YZK(K, I, J) ! Modified by Anders Ynnerman, at Vanderbilt : 03 Feb 1994 * ! Modified by Jacek Bieron at Vanderbilt : 08 Feb 1994 * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 10:51:01 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 10:51:01 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNN1 - USE CNC_C, ONLY: CNC5C - USE DEF_C, ONLY: ACCY - USE GRID_C - USE NCC_C - USE ORB_C + USE CNC_C, ONLY: CNC5C + USE DEF_C, ONLY: ACCY + USE GRID_C + USE NCC_C + USE ORB_C USE TATB_C, ONLY: ZK=>TA, YK=>TB, MTP USE WAVE_C, ONLY: MF , PF, QF !----------------------------------------------- @@ -49,99 +49,99 @@ SUBROUTINE YZK(K, I, J) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: K - INTEGER :: I - INTEGER :: J + INTEGER, INTENT(IN) :: K + INTEGER :: I + INTEGER :: J !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KLIMIT = 20 - INTEGER, PARAMETER :: KLIMIT1 = KLIMIT + 1 + INTEGER, PARAMETER :: KLIMIT = 20 + INTEGER, PARAMETER :: KLIMIT1 = KLIMIT + 1 !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II, MTPP1, MTPP3, MTPP4, KK, NP4 - REAL(DOUBLE), DIMENSION(NNN1) :: RHOP - REAL(DOUBLE), DIMENSION(NNN1,KLIMIT) :: RTTK, RTTKM, RTTK1, RTTKM1 + INTEGER :: II, MTPP1, MTPP3, MTPP4, KK, NP4 + REAL(DOUBLE), DIMENSION(NNN1) :: RHOP + REAL(DOUBLE), DIMENSION(NNN1,KLIMIT) :: RTTK, RTTKM, RTTK1, RTTKM1 REAL(DOUBLE), DIMENSION(NNN1) :: RM, WK, TEMP - REAL(DOUBLE) :: SUM, RTMP, ZKLIM, DIF - LOGICAL, DIMENSION(0:KLIMIT) :: KCALC + REAL(DOUBLE) :: SUM, RTMP, ZKLIM, DIF + LOGICAL, DIMENSION(0:KLIMIT) :: KCALC - SAVE KCALC, RTTK, RTTKM, RTTK1, RTTKM1, RM + SAVE KCALC, RTTK, RTTKM, RTTK1, RTTKM1, RM !----------------------------------------------- ! ! P_OINTER (PNTRPF,PF(NNNP,1)),(PNTRQF,QF(NNNP,1)) ! ! - DATA KCALC/ KLIMIT1*.FALSE./ - !EQUIVALENCE (TA(1), ZK(1)), (TB(1), YK(1)) - IF (.NOT.KCALC(K)) THEN - KCALC(K) = .TRUE. - IF (K > KLIMIT) THEN - WRITE (6, *) ' increase klimit in yzk.f ' - STOP - ENDIF - IF (K > 0) THEN - RTTK(2:N,K) = R(2:N)**K - RTTKM(2:N,K) = 1.D0/RTTK(2:N,K) - RTTK1(2:N,K) = RTTK(2:N,K)*R(2:N) - RTTKM1(2:N,K) = 1.D0/RTTK1(2:N,K) - RM(2:N) = 1.D0/R(2:N) - ELSE - RM(2:N) = 1.D0/R(2:N) - ENDIF - ENDIF + DATA KCALC/ KLIMIT1*.FALSE./ + !EQUIVALENCE (TA(1), ZK(1)), (TB(1), YK(1)) + IF (.NOT.KCALC(K)) THEN + KCALC(K) = .TRUE. + IF (K > KLIMIT) THEN + WRITE (6, *) ' increase klimit in yzk.f ' + STOP + ENDIF + IF (K > 0) THEN + RTTK(2:N,K) = R(2:N)**K + RTTKM(2:N,K) = 1.D0/RTTK(2:N,K) + RTTK1(2:N,K) = RTTK(2:N,K)*R(2:N) + RTTKM1(2:N,K) = 1.D0/RTTK1(2:N,K) + RM(2:N) = 1.D0/R(2:N) + ELSE + RM(2:N) = 1.D0/R(2:N) + ENDIF + ENDIF ! ! Determine maximum tabulation point as location beyond which ! RHOP (see comment statements below) would be zero; determine ! other important locations ! - MTP = MIN(MF(I),MF(J)) - MTPP1 = MTP + 1 - MTPP3 = MTP + 3 - MTPP4 = MTP + 4 + MTP = MIN(MF(I),MF(J)) + MTPP1 = MTP + 1 + MTPP3 = MTP + 3 + MTPP4 = MTP + 4 ! ! Compute RP(s)*(P (s)*P (s)+Q (s)*Q (s)) and store in RHOP ! I J I J ! - DO II = 2, MTP - RHOP(II) = RP(II)*(PF(II,I)*PF(II,J) + QF(II,I)*QF(II,J)) - END DO + DO II = 2, MTP + RHOP(II) = RP(II)*(PF(II,I)*PF(II,J) + QF(II,I)*QF(II,J)) + END DO ! ! Fill array TEMP with R**K * RHOP ! - TEMP(1) = 0.0D00 - IF (K == 0) THEN - TEMP(2:MTP) = RHOP(2:MTP) - ELSE - TEMP(2:MTP) = RTTK(2:MTP,K)*RHOP(2:MTP) - ENDIF + TEMP(1) = 0.0D00 + IF (K == 0) THEN + TEMP(2:MTP) = RHOP(2:MTP) + ELSE + TEMP(2:MTP) = RTTK(2:MTP,K)*RHOP(2:MTP) + ENDIF ! ! Set an additional four points to zero ! - TEMP(MTPP1:MTPP4) = 0.0D00 + TEMP(MTPP1:MTPP4) = 0.0D00 ! ! K ! Compute the first few values of R * ZK using semi-open ! Newton-Cotes formulae ! - ZK(1) = 0.0D00 - DO II = 2, 4 - SUM = 0.0D00 - DO KK = 2, 5 - SUM = SUM + CNC5C(KK,II)*TEMP(KK) - END DO - ZK(II) = SUM - END DO + ZK(1) = 0.0D00 + DO II = 2, 4 + SUM = 0.0D00 + DO KK = 2, 5 + SUM = SUM + CNC5C(KK,II)*TEMP(KK) + END DO + ZK(II) = SUM + END DO ! K ! Compute remainder of R * ZK: march out to MTP+3; use closed ! Newton-Cotes formula ! - DO II = 5, MTPP3 + DO II = 5, MTPP3 RTMP = C1*(TEMP(II-4)+TEMP(II)) + C2*(TEMP(II-3)+TEMP(II-1)) + C3*TEMP& - (II-2) - ZK(II) = ZK(II-4) + RTMP - END DO + (II-2) + ZK(II) = ZK(II-4) + RTMP + END DO ! ! K (K) ! Determine the asymptotic value of R * Z @@ -151,76 +151,76 @@ SUBROUTINE YZK(K, I, J) ! The Hartree-Fock Method for Atoms, John Wiley & Sons, ! New York, 1977, p 235. ! - IF (K == 0) THEN + IF (K == 0) THEN ! - IF (I == J) THEN - ZKLIM = 1.0D00 - ELSE - ZKLIM = 0.0D00 - ENDIF + IF (I == J) THEN + ZKLIM = 1.0D00 + ELSE + ZKLIM = 0.0D00 + ENDIF ! - DO KK = MTPP3, MTP, -1 - DIF = ZK(KK) - ZKLIM - IF (ABS(DIF) <= ACCY) CYCLE + DO KK = MTPP3, MTP, -1 + DIF = ZK(KK) - ZKLIM + IF (ABS(DIF) <= ACCY) CYCLE ZK(KK:KK-((-2-KK)/(-4)-1)*4:(-4)) = ZK(KK:KK-((-2-KK)/(-4)-1)*4:& - (-4)) - DIF - END DO + (-4)) - DIF + END DO ! - ELSE + ELSE ! - ZKLIM = ZK(MTPP3) + ZKLIM = ZK(MTPP3) ! - ENDIF + ENDIF ! ! Tabulate ZK for entire internal grid ! - IF (K == 0) THEN + IF (K == 0) THEN ! - ZK(MTPP4:N) = ZKLIM + ZK(MTPP4:N) = ZKLIM ! - ELSE + ELSE ! - ZK(2:MTPP3) = ZK(2:MTPP3)*RTTKM(2:MTPP3,K) + ZK(2:MTPP3) = ZK(2:MTPP3)*RTTKM(2:MTPP3,K) ! - ZK(MTPP4:N) = ZKLIM*RTTKM(MTPP4:N,K) + ZK(MTPP4:N) = ZKLIM*RTTKM(MTPP4:N,K) ! - ENDIF + ENDIF ! ! Start array WK / R**(K+1) ! - NP4 = N + 4 - WK(NP4:MTPP1:(-1)) = 0.0D00 + NP4 = N + 4 + WK(NP4:MTPP1:(-1)) = 0.0D00 ! ! Fill array TEMP with RHOP / R**(K+1) ; set TEMP(1) = 0 ! to avoid 0/0 case ! - TEMP(1) = 0.0D00 - IF (K == 0) THEN - TEMP(2:MTP) = RHOP(2:MTP)*RM(2:MTP) - ELSE - TEMP(2:MTP) = RHOP(2:MTP)*RTTKM1(2:MTP,K) - ENDIF + TEMP(1) = 0.0D00 + IF (K == 0) THEN + TEMP(2:MTP) = RHOP(2:MTP)*RM(2:MTP) + ELSE + TEMP(2:MTP) = RHOP(2:MTP)*RTTKM1(2:MTP,K) + ENDIF ! ! Compute remainder of WK / R**(K+1): march in to the origin ! - DO II = MTP, 2, -1 + DO II = MTP, 2, -1 WK(II) = WK(II+4) + C1*(TEMP(II)+TEMP(II+4)) + C2*(TEMP(II+1)+TEMP(II+& - 3)) + C3*TEMP(II+2) - END DO - WK(1) = 0.0D00 + 3)) + C3*TEMP(II+2) + END DO + WK(1) = 0.0D00 ! ! Compute WK ! - IF (K == 0) THEN - WK(2:MTP) = WK(2:MTP)*R(2:MTP) - ELSE - WK(2:MTP) = WK(2:MTP)*RTTK1(2:MTP,K) - ENDIF + IF (K == 0) THEN + WK(2:MTP) = WK(2:MTP)*R(2:MTP) + ELSE + WK(2:MTP) = WK(2:MTP)*RTTK1(2:MTP,K) + ENDIF ! ! Assemble solution ! - YK(1) = 0.0D00 - YK(2:N) = ZK(2:N) + WK(2:N) + YK(1) = 0.0D00 + YK(2:N) = ZK(2:N) + WK(2:N) ! - RETURN - END SUBROUTINE YZK + RETURN + END SUBROUTINE YZK diff --git a/src/lib/lib9290/yzk_I.f90 b/src/lib/lib9290/yzk_I.f90 index 0d6163147..b731185f2 100644 --- a/src/lib/lib9290/yzk_I.f90 +++ b/src/lib/lib9290/yzk_I.f90 @@ -1,14 +1,14 @@ - MODULE yzk_I + MODULE yzk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:51:01 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:51:01 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE yzk (K, I, J) - INTEGER KLIMIT - PARAMETER(KLIMIT=20) - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J + SUBROUTINE yzk (K, I, J) + INTEGER KLIMIT + PARAMETER(KLIMIT=20) + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J !VAST.../CNC5/ CNC5C(IN) !VAST.../DEF4/ ACCY(IN) !VAST.../GRID/ R(IN), RP(IN), N(IN) @@ -17,6 +17,6 @@ SUBROUTINE yzk (K, I, J) !VAST.../WAVE/ MF(IN) !VAST...Calls: PF, QF !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/Makefile b/src/lib/libdvd90/Makefile old mode 100755 new mode 100644 index e5c29a5ca..163a70f82 --- a/src/lib/libdvd90/Makefile +++ b/src/lib/libdvd90/Makefile @@ -3,7 +3,7 @@ LIBDIR = $(GRASP)/lib LIBA = $(LIBDIR)/libdvd90.a -LIBOBJ = $(OBJ) +LIBOBJ = $(OBJ) MODDIR = ../libmod MODL92 = ../lib9290 MODLMPIU90 = ../mpi90 @@ -26,8 +26,7 @@ $(LIBA) : $(LIBOBJ) ranlib $(LIBA) .f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ + $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ clean: - rm -f *.o *.mod core - + rm -f *.o *.mod core diff --git a/src/lib/libdvd90/Makefile_Ser b/src/lib/libdvd90/Makefile_Ser old mode 100755 new mode 100644 index 5f5dd8e2c..23b075bc8 --- a/src/lib/libdvd90/Makefile_Ser +++ b/src/lib/libdvd90/Makefile_Ser @@ -3,7 +3,7 @@ LIBDIR = $(GRASP)/lib LIBA = $(LIBDIR)/libdvd90.a -LIBOBJ = $(OBJ) +LIBOBJ = $(OBJ) MODDIR = ../libmod MODL92 = ../lib9290 VASTO = $(MODDIR)/vast_kind_param_M.o @@ -29,8 +29,7 @@ $(LIBA) : $(LIBOBJ) ranlib $(LIBA) .f90.o: - $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I . -o $@ + $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I . -o $@ clean: - rm -f *.o *.mod core - + rm -f *.o *.mod core diff --git a/src/lib/libdvd90/Makefile_mpi b/src/lib/libdvd90/Makefile_mpi old mode 100755 new mode 100644 index db39977f8..a2104fefb --- a/src/lib/libdvd90/Makefile_mpi +++ b/src/lib/libdvd90/Makefile_mpi @@ -3,7 +3,7 @@ LIBDIR = $(GRASP)/lib LIBA = $(LIBDIR)/libdvd90.a -LIBOBJ = $(OBJ) +LIBOBJ = $(OBJ) MODDIR = ../libmod MODL92 = ../lib9290 MODLMPIU90 = ../mpi90 @@ -30,8 +30,7 @@ $(LIBA) : $(LIBOBJ) ranlib $(LIBA) .f90.o: - $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ + $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ clean: - rm -f *.o *.mod core - + rm -f *.o *.mod core diff --git a/src/lib/libdvd90/adds_I.f90 b/src/lib/libdvd90/adds_I.f90 index 859be7763..f8ef9436c 100644 --- a/src/lib/libdvd90/adds_I.f90 +++ b/src/lib/libdvd90/adds_I.f90 @@ -1,18 +1,18 @@ - MODULE adds_I + MODULE adds_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE adds (N, LIM, KPASS, NNCV, BASIS, AB, S) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: LIM - INTEGER, INTENT(IN) :: KPASS - INTEGER, INTENT(IN) :: NNCV - REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS - REAL(DOUBLE), DIMENSION(N*LIM) :: AB - REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2), INTENT(OUT) :: S + SUBROUTINE adds (N, LIM, KPASS, NNCV, BASIS, AB, S) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: LIM + INTEGER, INTENT(IN) :: KPASS + INTEGER, INTENT(IN) :: NNCV + REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS + REAL(DOUBLE), DIMENSION(N*LIM) :: AB + REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2), INTENT(OUT) :: S !VAST...Calls: DDOT - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/dvdrvr_I.f90 b/src/lib/libdvd90/dvdrvr_I.f90 index 38d2b2594..d9f29ec0a 100644 --- a/src/lib/libdvd90/dvdrvr_I.f90 +++ b/src/lib/libdvd90/dvdrvr_I.f90 @@ -1,45 +1,45 @@ - MODULE dvdrvr_I + MODULE dvdrvr_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE dvdrvr (IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG& , ISELEC, CRITE, CRITC, CRITR, MAXITER, EIGVAL, BASIS, ORTHOBASIS, AB& - , S, TEMPS, SVEC, SCRA1, ISCRA2, INCV, ICV, OLDVAL, NLOOPS, IERR) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(INOUT) :: IRC - INTEGER, DIMENSION(*), INTENT(OUT) :: IREV - INTEGER, INTENT(IN) :: N - LOGICAL, INTENT(IN) :: HIEND - INTEGER, INTENT(IN) :: LIM - INTEGER :: MBLOCK - INTEGER, INTENT(IN) :: NOC - INTEGER, INTENT(IN) :: NUME - INTEGER, INTENT(IN) :: NIV - INTEGER, INTENT(IN) :: NEIG - INTEGER, DIMENSION(NEIG) :: ISELEC - REAL(DOUBLE) :: CRITE - REAL(DOUBLE) :: CRITC - REAL(DOUBLE) :: CRITR - INTEGER, INTENT(IN) :: MAXITER - REAL(DOUBLE), DIMENSION(LIM), INTENT(INOUT) :: EIGVAL - REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS - REAL(DOUBLE), DIMENSION(N*LIM + NOC*N) :: ORTHOBASIS - REAL(DOUBLE), DIMENSION(N*LIM) :: AB - REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: S - REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: TEMPS - REAL(DOUBLE), DIMENSION(LIM*LIM) :: SVEC - REAL(DOUBLE), DIMENSION(8*LIM), INTENT(INOUT) :: SCRA1 - INTEGER, DIMENSION(5*LIM) :: ISCRA2 - INTEGER, DIMENSION(LIM), INTENT(IN) :: INCV - INTEGER, DIMENSION(NUME + 1), INTENT(OUT) :: ICV - REAL(DOUBLE), DIMENSION(NUME + 1), INTENT(INOUT) :: OLDVAL - INTEGER, INTENT(INOUT) :: NLOOPS - INTEGER, INTENT(INOUT) :: IERR + , S, TEMPS, SVEC, SCRA1, ISCRA2, INCV, ICV, OLDVAL, NLOOPS, IERR) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(INOUT) :: IRC + INTEGER, DIMENSION(*), INTENT(OUT) :: IREV + INTEGER, INTENT(IN) :: N + LOGICAL, INTENT(IN) :: HIEND + INTEGER, INTENT(IN) :: LIM + INTEGER :: MBLOCK + INTEGER, INTENT(IN) :: NOC + INTEGER, INTENT(IN) :: NUME + INTEGER, INTENT(IN) :: NIV + INTEGER, INTENT(IN) :: NEIG + INTEGER, DIMENSION(NEIG) :: ISELEC + REAL(DOUBLE) :: CRITE + REAL(DOUBLE) :: CRITC + REAL(DOUBLE) :: CRITR + INTEGER, INTENT(IN) :: MAXITER + REAL(DOUBLE), DIMENSION(LIM), INTENT(INOUT) :: EIGVAL + REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS + REAL(DOUBLE), DIMENSION(N*LIM + NOC*N) :: ORTHOBASIS + REAL(DOUBLE), DIMENSION(N*LIM) :: AB + REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: S + REAL(DOUBLE), DIMENSION(LIM*(LIM + 1)/2) :: TEMPS + REAL(DOUBLE), DIMENSION(LIM*LIM) :: SVEC + REAL(DOUBLE), DIMENSION(8*LIM), INTENT(INOUT) :: SCRA1 + INTEGER, DIMENSION(5*LIM) :: ISCRA2 + INTEGER, DIMENSION(LIM), INTENT(IN) :: INCV + INTEGER, DIMENSION(NUME + 1), INTENT(OUT) :: ICV + REAL(DOUBLE), DIMENSION(NUME + 1), INTENT(INOUT) :: OLDVAL + INTEGER, INTENT(INOUT) :: NLOOPS + INTEGER, INTENT(INOUT) :: IERR !VAST.../MPI/ MYID(IN) !VAST...Calls: TSTSEL, SLAMCH, DCOPY, DSPEVX, OVFLOW, NEWVEC !VAST...Calls: DSCAL, MGS_NRM, ADDS, MULTBC, DAXPY, DDOT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/dvdson.f90 b/src/lib/libdvd90/dvdson.f90 index 937286cdd..02cb22411 100644 --- a/src/lib/libdvd90/dvdson.f90 +++ b/src/lib/libdvd90/dvdson.f90 @@ -1,6 +1,6 @@ SUBROUTINE DVDSON(IRC, IREV, N, LIM, NOC, ILOW, IHIGH, ISELEC, NIV, & MBLOCK, CRITE, CRITC, CRITR, MAXITER, WORK, IWRSZ, IWORK, IIWSZ, HIEND& - , NLOOPS, IERR) + , NLOOPS, IERR) !======================================================================= ! ! Author: Andreas Stathopoulos, Charlotte F. Fischer @@ -64,60 +64,60 @@ SUBROUTINE DVDSON(IRC, IREV, N, LIM, NOC, ILOW, IHIGH, ISELEC, NIV, & ! All the routines have IMPLICIT REAL*8 (A-H,O-Z) ! !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 ! Editted by C. F. Fischer 5/10/07 -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE initdvd_I - USE dvdrvr_I - !USE dscal_I - !USE dcopy_I + USE initdvd_I + USE dvdrvr_I + !USE dscal_I + !USE dcopy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: IRC - INTEGER :: N - INTEGER :: LIM - INTEGER :: NOC - INTEGER, INTENT(INOUT) :: ILOW - INTEGER, INTENT(INOUT) :: IHIGH - INTEGER :: NIV - INTEGER :: MBLOCK - INTEGER :: MAXITER - INTEGER, INTENT(IN) :: IWRSZ - INTEGER, INTENT(IN) :: IIWSZ - INTEGER :: NLOOPS -! INTEGER, INTENT(INOUT) :: IERR - INTEGER :: IERR - REAL(DOUBLE) :: CRITE - REAL(DOUBLE) :: CRITC - REAL(DOUBLE) :: CRITR - LOGICAL :: HIEND - INTEGER :: IREV(*) - INTEGER :: ISELEC(LIM) - INTEGER :: IWORK(IIWSZ) - REAL(DOUBLE) :: WORK(IWRSZ) + INTEGER :: IRC + INTEGER :: N + INTEGER :: LIM + INTEGER :: NOC + INTEGER, INTENT(INOUT) :: ILOW + INTEGER, INTENT(INOUT) :: IHIGH + INTEGER :: NIV + INTEGER :: MBLOCK + INTEGER :: MAXITER + INTEGER, INTENT(IN) :: IWRSZ + INTEGER, INTENT(IN) :: IIWSZ + INTEGER :: NLOOPS +! INTEGER, INTENT(INOUT) :: IERR + INTEGER :: IERR + REAL(DOUBLE) :: CRITE + REAL(DOUBLE) :: CRITC + REAL(DOUBLE) :: CRITR + LOGICAL :: HIEND + INTEGER :: IREV(*) + INTEGER :: ISELEC(LIM) + INTEGER :: IWORK(IIWSZ) + REAL(DOUBLE) :: WORK(IWRSZ) real(kind(0.0d0)) :: ddot !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NEIG, I, NUME, IORTHO, IBASIS, IEIGVAL, IAB, IS, ITEMPS, ISVEC& - , ISCRA1, IOLDVAL, ISCRA2, ISCRA3, IICV + , ISCRA1, IOLDVAL, ISCRA2, ISCRA3, IICV SAVE ! SAVE NEIG, I, NUME, IORTHO, IBASIS, IEIGVAL, IAB, IS, ITEMPS, ISVEC, & ! ISCRA1, IOLDVAL, ISCRA2, ISCRA3, IICV !----------------------------------------------- ! ! (this is for the reverse communication) - + !----------------------------------------------------------------------- ! (Important to the following is the concept of NUME, the distance of ! the index of the eigenpair wanted which is farthest from the @@ -126,7 +126,7 @@ SUBROUTINE DVDSON(IRC, IREV, N, LIM, NOC, ILOW, IHIGH, ISELEC, NIV, & ! if highest eigenpairs i1 N) IERR = IERR + 1 - IF (LIM <= 0) IERR = IERR + 2 - - HIEND = .FALSE. - - IF (ILOW<=0 .OR. ILOW>N) THEN + IERR = 0 + IF (LIM > N) IERR = IERR + 1 + IF (LIM <= 0) IERR = IERR + 2 + + HIEND = .FALSE. + + IF (ILOW<=0 .OR. ILOW>N) THEN ! ..Look for user choice of eigenpairs in ISELEC - IF (ISELEC(1) <= 0) THEN + IF (ISELEC(1) <= 0) THEN ! ..Nothing is given in ISELEC - IERR = IERR + 4 - ELSE + IERR = IERR + 4 + ELSE ! ..Find number of eigenpairs wanted, and their ! ..min/max indices - NEIG = 1 - ILOW = ISELEC(1) - IHIGH = ISELEC(1) - DO I = 2, LIM - IF (ISELEC(I) <= 0) EXIT - ILOW = MIN(ILOW,ISELEC(I)) - IHIGH = MAX(IHIGH,ISELEC(I)) - NEIG = NEIG + 1 - END DO + NEIG = 1 + ILOW = ISELEC(1) + IHIGH = ISELEC(1) + DO I = 2, LIM + IF (ISELEC(I) <= 0) EXIT + ILOW = MIN(ILOW,ISELEC(I)) + IHIGH = MAX(IHIGH,ISELEC(I)) + NEIG = NEIG + 1 + END DO ! ..Check if a very large index is asked for - IF (IHIGH > N) IERR = IERR + 8 - ENDIF - ELSE + IF (IHIGH > N) IERR = IERR + 8 + ENDIF + ELSE ! ..Look for a range between ILOW and IHIGH ! ..Invalid range. IHIGH>N - IF (IHIGH > N) IERR = IERR + 8 - NEIG = IHIGH - ILOW + 1 + IF (IHIGH > N) IERR = IERR + 8 + NEIG = IHIGH - ILOW + 1 ! ..Invalid range. IHIGH LIM) THEN + IF (NEIG <= 0) IERR = IERR + 16 + IF (NEIG > LIM) THEN ! ..Not enough Basis space. Increase LIM or decrease NEIG - IERR = IERR + 32 - ELSE + IERR = IERR + 32 + ELSE ! ..Fill in the ISELEC with the required indices - DO I = 1, NEIG - ISELEC(I) = ILOW + I - 1 - END DO - ENDIF - ENDIF - - IF (IERR /= 0) RETURN - - NUME = IHIGH + DO I = 1, NEIG + ISELEC(I) = ILOW + I - 1 + END DO + ENDIF + ENDIF + + IF (IERR /= 0) RETURN + + NUME = IHIGH ! ..Identify if few of the highest eigenpairs are wanted. - IF (ILOW + IHIGH - 1 > N) THEN - HIEND = .TRUE. - NUME = N - ILOW + 1 + IF (ILOW + IHIGH - 1 > N) THEN + HIEND = .TRUE. + NUME = N - ILOW + 1 ! ..Change the problem to a minimum eipenpairs one ! ..by picking the corresponding eigenpairs on the ! ..opposite side of the spectrum. - I = 1 - IF (NEIG > 0) THEN - ISELEC(:NEIG) = N - ISELEC(:NEIG) + 1 - I = NEIG + 1 - ENDIF - ENDIF + I = 1 + IF (NEIG > 0) THEN + ISELEC(:NEIG) = N - ISELEC(:NEIG) + 1 + I = NEIG + 1 + ENDIF + ENDIF ! ..duplications in ISELEC - IF (NEIG > NUME) IERR = IERR + 64 + IF (NEIG > NUME) IERR = IERR + 64 ! ..Not enough Basis space. Increase LIM or decrease NUME - IF (NUME>LIM .OR. NUME==LIM .AND. NUME/=N) IERR = IERR + 128 + IF (NUME>LIM .OR. NUME==LIM .AND. NUME/=N) IERR = IERR + 128 ! ..Size of Block out of bounds - IF (MBLOCK<1 .OR. MBLOCK>NEIG) IERR = IERR + 256 - + IF (MBLOCK<1 .OR. MBLOCK>NEIG) IERR = IERR + 256 + ! ..Check for enough workspace for Dvdson IF (IWRSZ LIM) THEN + NUME) IERR = IERR + 512 + + IF (NIV > LIM) THEN ! ..Check number of initial estimates NIV is lower than LIM. - WRITE (6, *) 'WARNING: Too many initial estimates.?' - WRITE (6, *) 'The routine needs at most:', LIM - IERR = IERR + 4096 - ELSE IF (NIV < NUME) THEN + WRITE (6, *) 'WARNING: Too many initial estimates.?' + WRITE (6, *) 'The routine needs at most:', LIM + IERR = IERR + 4096 + ELSE IF (NIV < NUME) THEN ! ..check if enough initial estimates. - WRITE (6, *) 'WARNING: Not enough initial estimates' - WRITE (6, *) NUME - NIV, ' Lanczos vectors will be added' - ENDIF - - IF (IERR /= 0) RETURN + WRITE (6, *) 'WARNING: Not enough initial estimates' + WRITE (6, *) NUME - NIV, ' Lanczos vectors will be added' + ENDIF + + IF (IERR /= 0) RETURN ! ! Assigning space for the real work arrays ! - IORTHO = 1 - IBASIS = IORTHO + N*NOC - IEIGVAL = IBASIS + N*LIM - IAB = IEIGVAL + LIM - IS = IAB + N*LIM - ITEMPS = IS + LIM*(LIM + 1)/2 - ISVEC = ITEMPS + LIM*(LIM + 1)/2 + IORTHO = 1 + IBASIS = IORTHO + N*NOC + IEIGVAL = IBASIS + N*LIM + IAB = IEIGVAL + LIM + IS = IAB + N*LIM + ITEMPS = IS + LIM*(LIM + 1)/2 + ISVEC = ITEMPS + LIM*(LIM + 1)/2 !CC iscra1 = iSvec + LIM*(NUME+1) - ISCRA1 = ISVEC + LIM*LIM - IOLDVAL = ISCRA1 + 8*LIM + ISCRA1 = ISVEC + LIM*LIM + IOLDVAL = ISCRA1 + 8*LIM ! ! Assigning space for the integer work arrays ! - ISCRA2 = 1 - ISCRA3 = ISCRA2 + 5*LIM - IICV = ISCRA3 + LIM + ISCRA2 = 1 + ISCRA3 = ISCRA2 + 5*LIM + IICV = ISCRA3 + LIM ! ! Initialize tha basis, the AB, the S. ! - - 100 CONTINUE + + 100 CONTINUE CALL INITDVD (IRC, IREV, N, NOC, NIV, NUME + 1, LIM, HIEND, WORK(ISCRA1)& - , WORK(IORTHO), WORK(IBASIS), WORK(IAB), WORK(IS)) + , WORK(IORTHO), WORK(IBASIS), WORK(IAB), WORK(IS)) ! ---------------------------------------------------------------- ! ..Reverse Communication for possible matrix vector - IF (IRC == 2) THEN - IREV(2) = IBASIS + (IREV(2)-1)*N - IREV(3) = IAB + (IREV(3)-1)*N - RETURN - ENDIF + IF (IRC == 2) THEN + IREV(2) = IBASIS + (IREV(2)-1)*N + IREV(3) = IAB + (IREV(3)-1)*N + RETURN + ENDIF ! ---------------------------------------------------------------- ! ! Call main driver routine. ! - NLOOPS = 1 - - 200 CONTINUE + NLOOPS = 1 + + 200 CONTINUE CALL DVDRVR (IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG, & ISELEC, CRITE, CRITC, CRITR, MAXITER, WORK(IEIGVAL), WORK(IBASIS), & WORK(IORTHO), WORK(IAB), WORK(IS), WORK(ITEMPS), WORK(ISVEC), WORK(& ISCRA1), IWORK(ISCRA2), IWORK(ISCRA3), IWORK(IICV), WORK(IOLDVAL), & - NLOOPS, IERR) + NLOOPS, IERR) ! ---------------------------------------------------------------- ! some Reverse Communication - IF (IRC == 1) THEN + IF (IRC == 1) THEN ! ..Preconditioning - IREV(2) = IAB + (IREV(2)-1)*N - IREV(3) = IBASIS + (IREV(3)-1)*N - IREV(4) = IEIGVAL - IREV(5) = ISCRA3 - IREV(6) = ISCRA1 - IREV(7) = ISCRA1 + LIM - RETURN - ELSE IF (IRC == 3) THEN + IREV(2) = IAB + (IREV(2)-1)*N + IREV(3) = IBASIS + (IREV(3)-1)*N + IREV(4) = IEIGVAL + IREV(5) = ISCRA3 + IREV(6) = ISCRA1 + IREV(7) = ISCRA1 + LIM + RETURN + ELSE IF (IRC == 3) THEN ! ..Matrix-vector - IREV(2) = IBASIS + (IREV(2)-1)*N - IREV(3) = IAB + (IREV(3)-1)*N - RETURN - ENDIF + IREV(2) = IBASIS + (IREV(2)-1)*N + IREV(3) = IAB + (IREV(3)-1)*N + RETURN + ENDIF ! ---------------------------------------------------------------- - - IF (HIEND) CALL DSCAL (NUME, -1.D0, WORK(IEIGVAL), 1) + + IF (HIEND) CALL DSCAL (NUME, -1.D0, WORK(IEIGVAL), 1) ! ! -Copy the eigenvalues after the eigenvectors ! -Next, copy the difference of eigenvalues between the last two steps ! -Next, copy the residuals for the first NUME estimates ! - CALL DCOPY (NUME, WORK(IEIGVAL), 1, WORK(IBASIS+N*NUME), 1) - CALL DCOPY (NUME, WORK(IOLDVAL), 1, WORK(IBASIS+(N+1)*NUME), 1) - CALL DCOPY (NUME, WORK(ISCRA1), 1, WORK(IBASIS+(N+2)*NUME), 1) + CALL DCOPY (NUME, WORK(IEIGVAL), 1, WORK(IBASIS+N*NUME), 1) + CALL DCOPY (NUME, WORK(IOLDVAL), 1, WORK(IBASIS+(N+1)*NUME), 1) + CALL DCOPY (NUME, WORK(ISCRA1), 1, WORK(IBASIS+(N+2)*NUME), 1) ! ! Set IRC=0 for normal exit with no reverse communication ! - IRC = 0 - RETURN - END SUBROUTINE DVDSON + IRC = 0 + RETURN + END SUBROUTINE DVDSON !======================================================================= - SUBROUTINE ADDS(N, LIM, KPASS, NNCV, BASIS, AB, S) + SUBROUTINE ADDS(N, LIM, KPASS, NNCV, BASIS, AB, S) !======================================================================= ! Called by: DVDSON ! @@ -493,34 +493,34 @@ SUBROUTINE ADDS(N, LIM, KPASS, NNCV, BASIS, AB, S) ! DDOT, DSCAL ! !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE ddot_I + !USE ddot_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER , INTENT(IN) :: LIM - INTEGER , INTENT(IN) :: KPASS - INTEGER , INTENT(IN) :: NNCV - REAL(DOUBLE) :: BASIS(N*LIM) - REAL(DOUBLE) :: AB(N*LIM) - REAL(DOUBLE) , INTENT(OUT) :: S(LIM*(LIM + 1)/2) + INTEGER :: N + INTEGER , INTENT(IN) :: LIM + INTEGER , INTENT(IN) :: KPASS + INTEGER , INTENT(IN) :: NNCV + REAL(DOUBLE) :: BASIS(N*LIM) + REAL(DOUBLE) :: AB(N*LIM) + REAL(DOUBLE) , INTENT(OUT) :: S(LIM*(LIM + 1)/2) real(kind(0.0d0)) :: ddot !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IDSTART, ISSTART, IV, IBSTART, IBV - REAL(DOUBLE) :: SS + INTEGER :: IDSTART, ISSTART, IV, IBSTART, IBV + REAL(DOUBLE) :: SS !----------------------------------------------- !----------------------------------------------------------------------- ! on entry @@ -538,27 +538,27 @@ SUBROUTINE ADDS(N, LIM, KPASS, NNCV, BASIS, AB, S) ! The new S is calculated by adding the new last columns ! S(new)=B^T D(new). ! - IDSTART = KPASS*N + 1 - ISSTART = KPASS*(KPASS + 1)/2 - DO IV = 1, NNCV - IBSTART = 1 - DO IBV = 1, KPASS + IV - SS = DDOT(N,BASIS(IBSTART),1,AB(IDSTART),1) - S(ISSTART+IBV) = SS - IBSTART = IBSTART + N - END DO - ISSTART = ISSTART + KPASS + IV - IDSTART = IDSTART + N - END DO - - RETURN - END SUBROUTINE ADDS + IDSTART = KPASS*N + 1 + ISSTART = KPASS*(KPASS + 1)/2 + DO IV = 1, NNCV + IBSTART = 1 + DO IBV = 1, KPASS + IV + SS = DDOT(N,BASIS(IBSTART),1,AB(IDSTART),1) + S(ISSTART+IBV) = SS + IBSTART = IBSTART + N + END DO + ISSTART = ISSTART + KPASS + IV + IDSTART = IDSTART + N + END DO + + RETURN + END SUBROUTINE ADDS !======================================================================= SUBROUTINE DVDRVR(IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG& , ISELEC, CRITE, CRITC, CRITR, MAXITER, EIGVAL, BASIS, ORTHOBASIS, AB& - , S, TEMPS, SVEC, SCRA1, ISCRA2, INCV, ICV, OLDVAL, NLOOPS, IERR) + , S, TEMPS, SVEC, SCRA1, ISCRA2, INCV, ICV, OLDVAL, NLOOPS, IERR) !======================================================================= ! called by DVDSON ! @@ -583,72 +583,72 @@ SUBROUTINE DVDRVR(IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG& ! DSPEVX, MULTBC, TSTSEL, OVFLOW, NEWVEC, ADDS, ! DCOPY, DDOT, DAXPY !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! USE MPI_C, ONLY: MYID !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE tstsel_I - USE newvec_I - USE mgs_nrm_I - USE adds_I - USE multbc_I + USE tstsel_I + USE newvec_I + USE mgs_nrm_I + USE adds_I + USE multbc_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IRC - INTEGER :: N - INTEGER :: LIM - INTEGER :: MBLOCK - INTEGER, INTENT(IN) :: NOC - INTEGER :: NUME - INTEGER, INTENT(IN) :: NIV - INTEGER :: NEIG - INTEGER, INTENT(IN) :: MAXITER - INTEGER, INTENT(INOUT) :: NLOOPS - INTEGER, INTENT(INOUT) :: IERR - REAL(DOUBLE) :: CRITE - REAL(DOUBLE) :: CRITC - REAL(DOUBLE) :: CRITR - LOGICAL, INTENT(IN) :: HIEND - INTEGER, INTENT(OUT) :: IREV(*) - INTEGER :: ISELEC(NEIG) - INTEGER :: ISCRA2(5*LIM) - INTEGER :: INCV(LIM) - INTEGER :: ICV(NUME + 1) - REAL(DOUBLE) :: EIGVAL(LIM) - REAL(DOUBLE) :: BASIS(N*LIM) - REAL(DOUBLE) :: ORTHOBASIS(N*LIM + NOC*N) - REAL(DOUBLE) :: AB(N*LIM) - REAL(DOUBLE) :: S(LIM*(LIM + 1)/2) - REAL(DOUBLE) :: TEMPS(LIM*(LIM + 1)/2) - REAL(DOUBLE) :: SVEC(LIM*LIM) - REAL(DOUBLE) :: SCRA1(8*LIM) - REAL(DOUBLE) :: OLDVAL(NUME + 1) + INTEGER, INTENT(INOUT) :: IRC + INTEGER :: N + INTEGER :: LIM + INTEGER :: MBLOCK + INTEGER, INTENT(IN) :: NOC + INTEGER :: NUME + INTEGER, INTENT(IN) :: NIV + INTEGER :: NEIG + INTEGER, INTENT(IN) :: MAXITER + INTEGER, INTENT(INOUT) :: NLOOPS + INTEGER, INTENT(INOUT) :: IERR + REAL(DOUBLE) :: CRITE + REAL(DOUBLE) :: CRITC + REAL(DOUBLE) :: CRITR + LOGICAL, INTENT(IN) :: HIEND + INTEGER, INTENT(OUT) :: IREV(*) + INTEGER :: ISELEC(NEIG) + INTEGER :: ISCRA2(5*LIM) + INTEGER :: INCV(LIM) + INTEGER :: ICV(NUME + 1) + REAL(DOUBLE) :: EIGVAL(LIM) + REAL(DOUBLE) :: BASIS(N*LIM) + REAL(DOUBLE) :: ORTHOBASIS(N*LIM + NOC*N) + REAL(DOUBLE) :: AB(N*LIM) + REAL(DOUBLE) :: S(LIM*(LIM + 1)/2) + REAL(DOUBLE) :: TEMPS(LIM*(LIM + 1)/2) + REAL(DOUBLE) :: SVEC(LIM*LIM) + REAL(DOUBLE) :: SCRA1(8*LIM) + REAL(DOUBLE) :: OLDVAL(NUME + 1) real(kind(0.0d0)) :: ddot real::slamch !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: REST, I, KPASS, NNCV, IFIND, NFOUND, INFO, NEWSTART - REAL(DOUBLE) :: TOL - LOGICAL :: FIRST, DONE + INTEGER :: REST, I, KPASS, NNCV, IFIND, NFOUND, INFO, NEWSTART + REAL(DOUBLE) :: TOL + LOGICAL :: FIRST, DONE SAVE FIRST, DONE, REST, I, KPASS, NNCV, IFIND, TOL, NFOUND, INFO, & - NEWSTART + NEWSTART !----------------------------------------------- !CC DIMENSION SVEC(LIM*(NUME+1)),EIGVAL(LIM) ! ! !include 'mpif.h' ! (this is for the reverse communication) - + !----------------------------------------------------------------------- ! ! on entry @@ -689,164 +689,164 @@ SUBROUTINE DVDRVR(IRC, IREV, N, HIEND, LIM, MBLOCK, NOC, NUME, NIV, NEIG& ! NLOOPS Number of loops taken by the algorithm ! !----------------------------------------------------------------------- - + !----------------------------------------------------------------------- ! Reverse Communication - IF (IRC == 1) THEN + IF (IRC == 1) THEN ! ..Came from preconditioning - GO TO 100 - ELSE IF (IRC == 3) THEN + GO TO 100 + ELSE IF (IRC == 3) THEN ! ..came from matrix vector multiply - GO TO 200 - ENDIF + GO TO 200 + ENDIF !----------------------------------------------------------------------- - - I = 1 - IF (NUME > 0) THEN - EIGVAL(:NUME) = 1.D30 - ICV(:NUME) = 0 - I = NUME + 1 - ENDIF - FIRST = .TRUE. - KPASS = NIV - NNCV = KPASS + + I = 1 + IF (NUME > 0) THEN + EIGVAL(:NUME) = 1.D30 + ICV(:NUME) = 0 + I = NUME + 1 + ENDIF + FIRST = .TRUE. + KPASS = NIV + NNCV = KPASS ! ! Decide HERE how many to restart with, not more than LIM-3. ! - REST = MAX(LIM/2,2*NUME) - REST = MIN(REST,LIM - 3) - - 10 CONTINUE - IFIND = MIN(KPASS,REST) - TOL = SLAMCH('S') - CALL DCOPY (IFIND, EIGVAL, 1, OLDVAL, 1) - CALL DCOPY ((KPASS*(KPASS + 1))/2, S, 1, TEMPS, 1) + REST = MAX(LIM/2,2*NUME) + REST = MIN(REST,LIM - 3) + + 10 CONTINUE + IFIND = MIN(KPASS,REST) + TOL = SLAMCH('S') + CALL DCOPY (IFIND, EIGVAL, 1, OLDVAL, 1) + CALL DCOPY ((KPASS*(KPASS + 1))/2, S, 1, TEMPS, 1) CALL DSPEVX ('Vectors also', 'In a range', 'Upper triangular', KPASS, & TEMPS, -1., -1., 1, IFIND, TOL, NFOUND, EIGVAL, SVEC, KPASS, SCRA1, & - ISCRA2, INCV, INFO) - IERR = -ABS(INFO) - IF (IERR /= 0) GO TO 60 + ISCRA2, INCV, INFO) + IERR = -ABS(INFO) + IF (IERR /= 0) GO TO 60 ! ! TeST for convergence on the absolute difference of eigenvalues between ! successive steps. Also SELect the unconverged eigenpairs and sort them ! by the largest magnitude in the last added NNCV rows of Svec. ! DONE = TSTSEL(KPASS,NUME,NEIG,ISELEC,SVEC,EIGVAL,ICV,CRITE,CRITC,SCRA1,& - ISCRA2,OLDVAL,NNCV,INCV) - IF (DONE .OR. KPASS>=N) GO TO 30 + ISCRA2,OLDVAL,NNCV,INCV) + IF (DONE .OR. KPASS>=N) GO TO 30 ! ! Maximum size for expanding basis. Truncate basis, D, and S, Svec ! Consider the basis vectors found in TSTSEL for the newvec. KPASS=NUME ! - + ! Change suggested by Anreas, March 18, 1996 - IF (KPASS == LIM) THEN + IF (KPASS == LIM) THEN ! PRINT*,'collapsing the basis: lim,nume,rest',lim,nume,rest ! PRINT*,'myid = ', myid, ' nprocs = ', nprocs ! PRINT*,'collapsing the basis: lim,nume,rest',lim,nume,rest,myid !23456789012345678901234567890123456789012345678901234567890123456789012 - CALL OVFLOW (N, REST, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) + CALL OVFLOW (N, REST, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) ! CALL OVFLOW(N,NUME,KPASS,SCRA1,BASIS,AB,S,SVEC,EIGVAL) - ENDIF + ENDIF ! ! Compute and add the new residuals. NNCV is set to the number of new ! vectors that have not converged. If none, DONE=true, exit. ! CALL NEWVEC (N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC, EIGVAL& - , OLDVAL, AB, BASIS, ICV, SCRA1, SCRA1(LIM+1), DONE) - - IF (DONE) GO TO 30 + , OLDVAL, AB, BASIS, ICV, SCRA1, SCRA1(LIM+1), DONE) + + IF (DONE) GO TO 30 !----------------------------------------------------------------------- ! Preconditioning the NNCV (residuals-deps x) stored in AB(kpass+1). ! ..Robust Preconditioning (Eigenvalue shift). ! ..Look for lowest, so Li-|eps_i| - DO I = 1, NNCV - EIGVAL(INCV(I)) = EIGVAL(INCV(I)) - SCRA1(LIM+INCV(I)) - END DO + DO I = 1, NNCV + EIGVAL(INCV(I)) = EIGVAL(INCV(I)) - SCRA1(LIM+INCV(I)) + END DO ! ! ..Change sign of eigenvalues if HIEND. - IF (HIEND) CALL DSCAL (NUME, -1.D0, EIGVAL, 1) - + IF (HIEND) CALL DSCAL (NUME, -1.D0, EIGVAL, 1) + ! Use of Reverse Communication. ! - IREV(1) = NNCV - IREV(2) = KPASS + 1 - IREV(3) = KPASS + 1 - IRC = 1 - IF (IRC == 1) RETURN + IREV(1) = NNCV + IREV(2) = KPASS + 1 + IREV(3) = KPASS + 1 + IRC = 1 + IF (IRC == 1) RETURN ! ..Continue from preconditioning - 100 CONTINUE - IF (HIEND) CALL DSCAL (NUME, -1.D0, EIGVAL, 1) + 100 CONTINUE + IF (HIEND) CALL DSCAL (NUME, -1.D0, EIGVAL, 1) ! ! ..Shift the eigenvalues back to what they were. - DO I = 1, NNCV - EIGVAL(INCV(I)) = EIGVAL(INCV(I)) + SCRA1(LIM+INCV(I)) - END DO + DO I = 1, NNCV + EIGVAL(INCV(I)) = EIGVAL(INCV(I)) + SCRA1(LIM+INCV(I)) + END DO !----------------------------------------------------------------------- ! ! Orthonormalization of the previous vectors to the Basis and to any ! orthogonalization constraints. The not-yet-filled ! spaces of AB (from NEWSATRT onwards) are used for scratch. ! - NEWSTART = KPASS*N + 1 - - CALL MGS_NRM (N, NOC + KPASS, NNCV, SCRA1(LIM+1), ORTHOBASIS) + NEWSTART = KPASS*N + 1 + + CALL MGS_NRM (N, NOC + KPASS, NNCV, SCRA1(LIM+1), ORTHOBASIS) !----------------------------------------------------------------------- ! Use of Reverse Communication. Add new columns in D through matrix vector ! multiplication CALL OP(N,NNCV,BASIS(NEWSTART),AB(NEWSTART)) ! - IREV(1) = NNCV - IREV(2) = KPASS + 1 - IREV(3) = KPASS + 1 - IRC = 3 - RETURN - + IREV(1) = NNCV + IREV(2) = KPASS + 1 + IREV(3) = KPASS + 1 + IRC = 3 + RETURN + ! ..Continue from matrix-vector multiply - 200 CONTINUE - IF (HIEND) CALL DSCAL (N*NNCV, -1.D0, AB(NEWSTART), 1) + 200 CONTINUE + IF (HIEND) CALL DSCAL (N*NNCV, -1.D0, AB(NEWSTART), 1) ! ! Add new column in S, from the NNCV new vectors. ! - CALL ADDS (N, LIM, KPASS, NNCV, BASIS, AB, S) - - KPASS = KPASS + NNCV - NLOOPS = NLOOPS + 1 - - IF (NLOOPS <= MAXITER) GO TO 10 - IERR = IERR + 2048 - NLOOPS = NLOOPS - 1 - KPASS = KPASS - NNCV - 30 CONTINUE - DO I = 1, NUME - OLDVAL(I) = ABS(OLDVAL(I)-EIGVAL(I)) - END DO - - CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, BASIS) - CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, AB) + CALL ADDS (N, LIM, KPASS, NNCV, BASIS, AB, S) + + KPASS = KPASS + NNCV + NLOOPS = NLOOPS + 1 + + IF (NLOOPS <= MAXITER) GO TO 10 + IERR = IERR + 2048 + NLOOPS = NLOOPS - 1 + KPASS = KPASS - NNCV + 30 CONTINUE + DO I = 1, NUME + OLDVAL(I) = ABS(OLDVAL(I)-EIGVAL(I)) + END DO + + CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, BASIS) + CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, AB) ! ! i=1,NUME residual(i)= DCi-liBCi= newDi-linewBi ! temporarily stored in AB(NUME*N+1) ! - DO I = 1, NUME - CALL DCOPY (N, AB((I-1)*N+1), 1, AB(NUME*N+1), 1) - CALL DAXPY (N, (-EIGVAL(I)),BASIS((I-1)*N+1), 1, AB(NUME*N+1), 1) - SCRA1(I) = DDOT(N,AB(NUME*N+1),1,AB(NUME*N+1),1) - SCRA1(I) = SQRT(SCRA1(I)) - END DO + DO I = 1, NUME + CALL DCOPY (N, AB((I-1)*N+1), 1, AB(NUME*N+1), 1) + CALL DAXPY (N, (-EIGVAL(I)),BASIS((I-1)*N+1), 1, AB(NUME*N+1), 1) + SCRA1(I) = DDOT(N,AB(NUME*N+1),1,AB(NUME*N+1),1) + SCRA1(I) = SQRT(SCRA1(I)) + END DO ! ! Set IRC=0 for normal exit with no reverse communication ! -! IF (MYID == 0) WRITE (6, *) 'DVDSON::NLOOPS =', NLOOPS - 60 CONTINUE - IRC = 0 - RETURN - END SUBROUTINE DVDRVR +! IF (MYID == 0) WRITE (6, *) 'DVDSON::NLOOPS =', NLOOPS + 60 CONTINUE + IRC = 0 + RETURN + END SUBROUTINE DVDRVR !======================================================================= SUBROUTINE INITDVD(IRC, IREV, N, NOC, NIV, NUME, LIM, HIEND, SCRA1, & - ORTHOBASIS, BASIS, AB, S) + ORTHOBASIS, BASIS, AB, S) !======================================================================= ! Initializes the basis and the auxiliary arrays AB and S. ! If not enough initial estimates exist the basis will be @@ -857,100 +857,100 @@ SUBROUTINE INITDVD(IRC, IREV, N, NOC, NIV, NUME, LIM, HIEND, SCRA1, & ! constraint vectors in the begining. This equialence holds: ! equivalence(Basis(1),OrthoBasis(NOC*N+1)) !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE dinit_I - !USE dcopy_I - USE mgs_nrm_I - !USE dscal_I - USE adds_I + !USE dinit_I + !USE dcopy_I + USE mgs_nrm_I + !USE dscal_I + USE adds_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(INOUT) :: IRC - INTEGER :: N - INTEGER, INTENT(IN) :: NOC - INTEGER :: NIV - INTEGER, INTENT(IN) :: NUME - INTEGER :: LIM - LOGICAL, INTENT(IN) :: HIEND - INTEGER, INTENT(OUT) :: IREV(*) - REAL(DOUBLE) :: SCRA1(*) - REAL(DOUBLE) :: ORTHOBASIS(N*(NOC + LIM)) - REAL(DOUBLE) :: BASIS(N*LIM) - REAL(DOUBLE) :: AB(N*LIM) - REAL(DOUBLE) :: S(*) + INTEGER, INTENT(INOUT) :: IRC + INTEGER :: N + INTEGER, INTENT(IN) :: NOC + INTEGER :: NIV + INTEGER, INTENT(IN) :: NUME + INTEGER :: LIM + LOGICAL, INTENT(IN) :: HIEND + INTEGER, INTENT(OUT) :: IREV(*) + REAL(DOUBLE) :: SCRA1(*) + REAL(DOUBLE) :: ORTHOBASIS(N*(NOC + LIM)) + REAL(DOUBLE) :: BASIS(N*LIM) + REAL(DOUBLE) :: AB(N*LIM) + REAL(DOUBLE) :: S(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IST, IEND, NEW, KPASS + INTEGER :: IST, IEND, NEW, KPASS - SAVE IST, IEND, NEW, KPASS + SAVE IST, IEND, NEW, KPASS !----------------------------------------------- ! !----------------------------------------------------------------------- ! ..Reverse Communication - IF (IRC == 2) GO TO 100 + IF (IRC == 2) GO TO 100 !----------------------------------------------------------------------- ! ! If no initial estimates pick one ! - IF (NIV == 0) THEN - CALL DINIT (N, 1.D0/SQRT(DBLE(N)), BASIS, 1) - NIV = 1 - ENDIF + IF (NIV == 0) THEN + CALL DINIT (N, 1.D0/SQRT(DBLE(N)), BASIS, 1) + NIV = 1 + ENDIF ! ! Compute AB. Also fill basis with orthonormalized ABs until enough NIVs. ! - IST = 1 - IEND = NIV - NEW = NIV - 10 CONTINUE - IRC = 2 - IREV(1) = NEW - IREV(2) = IST - IREV(3) = IST - RETURN - 100 CONTINUE - IF (IEND < NUME) THEN - NEW = MIN(NUME - IEND,IEND - IST + 1) - CALL DCOPY (N*NEW, AB((IST-1)*N+1), 1, BASIS(1+IEND*N), 1) + IST = 1 + IEND = NIV + NEW = NIV + 10 CONTINUE + IRC = 2 + IREV(1) = NEW + IREV(2) = IST + IREV(3) = IST + RETURN + 100 CONTINUE + IF (IEND < NUME) THEN + NEW = MIN(NUME - IEND,IEND - IST + 1) + CALL DCOPY (N*NEW, AB((IST-1)*N+1), 1, BASIS(1+IEND*N), 1) ! ..orthonormalize OrthoBasis i.e., ! B-1..B-noc,B1,...,Biend,( Biend+1,...Biend+new ) - CALL MGS_NRM (N, NOC + IEND, NEW, SCRA1, ORTHOBASIS) - IST = IEND + 1 - IEND = IEND + NEW - GO TO 10 - ENDIF - NIV = IEND + CALL MGS_NRM (N, NOC + IEND, NEW, SCRA1, ORTHOBASIS) + IST = IEND + 1 + IEND = IEND + NEW + GO TO 10 + ENDIF + NIV = IEND !xhh print*, 'niv=',niv, 'nume=', nume ! ! Scale if HIEND for highest eigepairs ! - IF (HIEND) CALL DSCAL (N*NIV, -1.D0, AB, 1) + IF (HIEND) CALL DSCAL (N*NIV, -1.D0, AB, 1) ! ! Also find the small matrix S = B^TAB. ! - KPASS = 0 - CALL ADDS (N, LIM, KPASS, NIV, BASIS, AB, S) - - IRC = 0 - RETURN - END SUBROUTINE INITDVD + KPASS = 0 + CALL ADDS (N, LIM, KPASS, NIV, BASIS, AB, S) + + IRC = 0 + RETURN + END SUBROUTINE INITDVD + - !======================================================================= - SUBROUTINE MULTBC(N, K, M, C, TEMP, B) + SUBROUTINE MULTBC(N, K, M, C, TEMP, B) !======================================================================= ! called by: DVDRVR ! @@ -961,46 +961,46 @@ SUBROUTINE MULTBC(N, K, M, C, TEMP, B) ! Subroutines called ! DINIT, DGEMV, DCOPY !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE dgemv_I - !USE dcopy_I + !USE dgemv_I + !USE dcopy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: K - INTEGER :: M - REAL(DOUBLE) :: C(K*M) - REAL(DOUBLE) :: TEMP(M) - REAL(DOUBLE) :: B(N*K) + INTEGER :: N + INTEGER :: K + INTEGER :: M + REAL(DOUBLE) :: C(K*M) + REAL(DOUBLE) :: TEMP(M) + REAL(DOUBLE) :: B(N*K) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IROW + INTEGER :: IROW !----------------------------------------------- !----------------------------------------------------------------------- - DO IROW = 1, N - CALL DGEMV ('Transp', K, M, 1.D0, C, K, B(IROW), N, 0.D0, TEMP, 1) - CALL DCOPY (M, TEMP, 1, B(IROW), N) - END DO - - RETURN - END SUBROUTINE MULTBC + DO IROW = 1, N + CALL DGEMV ('Transp', K, M, 1.D0, C, K, B(IROW), N, 0.D0, TEMP, 1) + CALL DCOPY (M, TEMP, 1, B(IROW), N) + END DO + + RETURN + END SUBROUTINE MULTBC !======================================================================= SUBROUTINE NEWVEC(N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC, & - EIGVAL, OLDVAL, AB, BASIS, ICV, SCRA1, EPSIL, DONE) + EIGVAL, OLDVAL, AB, BASIS, ICV, SCRA1, EPSIL, DONE) !======================================================================= ! ! Called by: DVDRVR @@ -1022,13 +1022,13 @@ SUBROUTINE NEWVEC(N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC, & ! DNRM2, DGEMV ! !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! USE MPI_C, ONLY: MYID !----------------------------------------------- ! I n t e r f a c e B l o c k s @@ -1037,29 +1037,29 @@ SUBROUTINE NEWVEC(N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC, & !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER , INTENT(IN) :: NUME - INTEGER , INTENT(IN) :: LIM - INTEGER , INTENT(IN) :: MBLOCK - INTEGER :: KPASS - INTEGER , INTENT(INOUT) :: NNCV - REAL(DOUBLE) , INTENT(IN) :: CRITR - LOGICAL , INTENT(OUT) :: DONE - INTEGER , INTENT(INOUT) :: INCV(NUME) - INTEGER , INTENT(OUT) :: ICV(NUME) - REAL(DOUBLE) :: SVEC(LIM*NUME) - REAL(DOUBLE) , INTENT(IN) :: EIGVAL(LIM) - REAL(DOUBLE) , INTENT(IN) :: OLDVAL(NUME) - REAL(DOUBLE) :: AB(N*LIM) - REAL(DOUBLE) :: BASIS(N*LIM) - REAL(DOUBLE) , INTENT(INOUT) :: SCRA1(LIM) - REAL(DOUBLE) , INTENT(OUT) :: EPSIL(LIM) + INTEGER :: N + INTEGER , INTENT(IN) :: NUME + INTEGER , INTENT(IN) :: LIM + INTEGER , INTENT(IN) :: MBLOCK + INTEGER :: KPASS + INTEGER , INTENT(INOUT) :: NNCV + REAL(DOUBLE) , INTENT(IN) :: CRITR + LOGICAL , INTENT(OUT) :: DONE + INTEGER , INTENT(INOUT) :: INCV(NUME) + INTEGER , INTENT(OUT) :: ICV(NUME) + REAL(DOUBLE) :: SVEC(LIM*NUME) + REAL(DOUBLE) , INTENT(IN) :: EIGVAL(LIM) + REAL(DOUBLE) , INTENT(IN) :: OLDVAL(NUME) + REAL(DOUBLE) :: AB(N*LIM) + REAL(DOUBLE) :: BASIS(N*LIM) + REAL(DOUBLE) , INTENT(INOUT) :: SCRA1(LIM) + REAL(DOUBLE) , INTENT(OUT) :: EPSIL(LIM) real(kind(0.0d0)) :: ddot !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NEWSTART, NADDED, ICVC, LIMADD, ICUR, I, INDX - REAL(DOUBLE) :: SQRES, GAPLOW, GAP, GAPUP, DL, RES, RHSEPS + INTEGER :: NEWSTART, NADDED, ICVC, LIMADD, ICUR, I, INDX + REAL(DOUBLE) :: SQRES, GAPLOW, GAP, GAPUP, DL, RES, RHSEPS !----------------------------------------------- !----------------------------------------------------------------------- ! on entry @@ -1088,95 +1088,95 @@ SUBROUTINE NEWVEC(N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC, & ! the Basis should be collapsed to current approximations. !----------------------------------------------------------------------- ! !include 'mpif.h' - DONE = .FALSE. - NEWSTART = KPASS*N + 1 - NADDED = 0 - ICVC = 0 - LIMADD = MIN(LIM,MBLOCK + KPASS) - ICUR = NEWSTART + DONE = .FALSE. + NEWSTART = KPASS*N + 1 + NADDED = 0 + ICVC = 0 + LIMADD = MIN(LIM,MBLOCK + KPASS) + ICUR = NEWSTART ! ! Compute RESIDUALS for the MBLOCK of the NNCV not converged vectors. ! - DO I = 1, NNCV - INDX = INCV(I) + DO I = 1, NNCV + INDX = INCV(I) ! ! ..Compute b = BASIS*Svec_indx ! ..Compute d = AB*Svec_indx ! ..Daxpy d'= d - eigval b gives the residual CALL DGEMV ('N', N, KPASS, 1.D0, BASIS, N, SVEC((INDX-1)*KPASS+1) & - , 1, 0.D0, BASIS(ICUR), 1) + , 1, 0.D0, BASIS(ICUR), 1) CALL DGEMV ('N', N, KPASS, 1.D0, AB, N, SVEC((INDX-1)*KPASS+1), 1, & - 0.D0, AB(ICUR), 1) - CALL DAXPY (N, (-EIGVAL(INDX)),BASIS(ICUR), 1, AB(ICUR), 1) + 0.D0, AB(ICUR), 1) + CALL DAXPY (N, (-EIGVAL(INDX)),BASIS(ICUR), 1, AB(ICUR), 1) ! ! ..Compute the norm of the residual ! ..and check for convergence ! - SQRES = DDOT(N,AB(ICUR),1,AB(ICUR),1) - SCRA1(INDX) = SQRT(SQRES) - + SQRES = DDOT(N,AB(ICUR),1,AB(ICUR),1) + SCRA1(INDX) = SQRT(SQRES) + ! IF (MYID == 0) WRITE (6, '(A11,F22.16,I2,A10,F19.16)') ' EIGVAL(i) ', & -! EIGVAL(INDX), INDX, ' Res.Norm ', SCRA1(INDX) - - IF (SCRA1(INDX) < CRITR) THEN +! EIGVAL(INDX), INDX, ' Res.Norm ', SCRA1(INDX) + + IF (SCRA1(INDX) < CRITR) THEN ! ..Converged,do not add. Go for next non converged one - ICVC = ICVC + 1 - ICV(INDX) = 1 - IF (ICVC < NNCV) CYCLE + ICVC = ICVC + 1 + ICV(INDX) = 1 + IF (ICVC < NNCV) CYCLE ! ..All have converged. !print*, 'converged by critr' !print*, 'converged by critr',myid - DONE = .TRUE. - RETURN - ELSE + DONE = .TRUE. + RETURN + ELSE ! ..Not converged. Consider it for preconditioning ! --------------- ROBUST MODIFICATION --------------------- ! ..Daxpy d'= d'- \delta_eps b gives the rhs for precond. ! ..It is stored in AB. ! ..Deps are also stored in EPSIL ! - IF (INDX == 1) THEN - GAPLOW = 1.0D+99 - GAP = ABS(EIGVAL(2)-EIGVAL(1)) + IF (INDX == 1) THEN + GAPLOW = 1.0D+99 + GAP = ABS(EIGVAL(2)-EIGVAL(1)) ! print*, 'h1,h2:',eigval(1),eigval(2) - ELSE - GAPLOW = ABS(EIGVAL(INDX)-EIGVAL(INDX-1)) - GAPUP = ABS(EIGVAL(INDX+1)-EIGVAL(INDX)) - GAP = MIN(GAPLOW,GAPUP) - ENDIF - DL = ABS(OLDVAL(INDX)-EIGVAL(INDX)) - RES = SCRA1(INDX) - - IF (GAP > RES) THEN + ELSE + GAPLOW = ABS(EIGVAL(INDX)-EIGVAL(INDX-1)) + GAPUP = ABS(EIGVAL(INDX+1)-EIGVAL(INDX)) + GAP = MIN(GAPLOW,GAPUP) + ENDIF + DL = ABS(OLDVAL(INDX)-EIGVAL(INDX)) + RES = SCRA1(INDX) + + IF (GAP > RES) THEN ! EPSIL(indx) = min(dl,res,gaplow) - RHSEPS = SQRT(DL*RES) - ELSE + RHSEPS = SQRT(DL*RES) + ELSE ! EPSIL(indx) = min( res, gaplow) - RHSEPS = MIN(DL,SQRT(DL)) - ENDIF - - EPSIL(INDX) = 0.D0 - CALL DAXPY (N, (-RHSEPS), BASIS(ICUR), 1, AB(ICUR), 1) - + RHSEPS = MIN(DL,SQRT(DL)) + ENDIF + + EPSIL(INDX) = 0.D0 + CALL DAXPY (N, (-RHSEPS), BASIS(ICUR), 1, AB(ICUR), 1) + ! -------------- END OF ROBUST MODIFICATIONS ----------------- ! - NADDED = NADDED + 1 - INCV(NADDED) = INDX - IF (NADDED + KPASS == LIMADD) EXIT + NADDED = NADDED + 1 + INCV(NADDED) = INDX + IF (NADDED + KPASS == LIMADD) EXIT ! ..More to be added in the block - ICUR = ICUR + N - ENDIF - END DO - - NNCV = NADDED - - RETURN - END SUBROUTINE NEWVEC + ICUR = ICUR + N + ENDIF + END DO + + NNCV = NADDED + + RETURN + END SUBROUTINE NEWVEC !======================================================================= - SUBROUTINE OVFLOW(N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) + SUBROUTINE OVFLOW(N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) !======================================================================= ! Called by: DVDRVR ! Called when the upper limit (LIM) has been reached for the basis @@ -1189,36 +1189,36 @@ SUBROUTINE OVFLOW(N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) ! Subroutines called: ! DCOPY, DINIT, MULTBC !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE multbc_I - !USE dinit_I + !USE multbc_I + !USE dinit_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: NUME - INTEGER :: KPASS -!CFF ... add dimensionto SCRA1 - REAL(DOUBLE) :: SCRA1(NUME) - REAL(DOUBLE) :: BASIS(N*KPASS) - REAL(DOUBLE) :: AB(N*KPASS) - REAL(DOUBLE) :: S((KPASS*(KPASS + 1))/2) - REAL(DOUBLE) :: SVEC(KPASS*NUME) - REAL(DOUBLE) , INTENT(IN) :: EIGVAL(KPASS) + INTEGER :: N + INTEGER :: NUME + INTEGER :: KPASS +!CFF ... add dimensionto SCRA1 + REAL(DOUBLE) :: SCRA1(NUME) + REAL(DOUBLE) :: BASIS(N*KPASS) + REAL(DOUBLE) :: AB(N*KPASS) + REAL(DOUBLE) :: S((KPASS*(KPASS + 1))/2) + REAL(DOUBLE) :: SVEC(KPASS*NUME) + REAL(DOUBLE) , INTENT(IN) :: EIGVAL(KPASS) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IND, ICUR, I + INTEGER :: IND, ICUR, I !----------------------------------------------- ! on entry ! ------- @@ -1233,32 +1233,32 @@ SUBROUTINE OVFLOW(N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) !----------------------------------------------------------------------- ! Truncate the basis and the AB array. ! - CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, BASIS) - CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, AB) + CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, BASIS) + CALL MULTBC (N, KPASS, NUME, SVEC, SCRA1, AB) ! ! calculation of the new upper S=diag(l1,...,l_NUME) and ! its matrix Svec of eigenvectors (e1,...,e_NUME) ! - CALL DINIT ((NUME*(NUME + 1))/2, 0.D0, S, 1) - CALL DINIT (NUME*NUME, 0.D0, SVEC, 1) - IND = 0 - ICUR = 0 - DO I = 1, NUME - S(IND+I) = EIGVAL(I) - SVEC(ICUR+I) = 1 - ICUR = ICUR + NUME - IND = IND + I - END DO - - KPASS = NUME - - RETURN - END SUBROUTINE OVFLOW + CALL DINIT ((NUME*(NUME + 1))/2, 0.D0, S, 1) + CALL DINIT (NUME*NUME, 0.D0, SVEC, 1) + IND = 0 + ICUR = 0 + DO I = 1, NUME + S(IND+I) = EIGVAL(I) + SVEC(ICUR+I) = 1 + ICUR = ICUR + NUME + IND = IND + I + END DO + + KPASS = NUME + + RETURN + END SUBROUTINE OVFLOW !======================================================================= LOGICAL FUNCTION TSTSEL (KPASS, NUME, NEIG, ISELEC, SVEC, EIGVAL, ICV, & - CRITE, CRITC, ROWLAST, IND, OLDVAL, NNCV, INCV) + CRITE, CRITC, ROWLAST, IND, OLDVAL, NNCV, INCV) !======================================================================= ! ! Called by: DVDRVR @@ -1278,42 +1278,42 @@ LOGICAL FUNCTION TSTSEL (KPASS, NUME, NEIG, ISELEC, SVEC, EIGVAL, ICV, & ! Subroutines called ! IDAMAX !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE -! USE MPI_C + USE vast_kind_param, ONLY: DOUBLE +! USE MPI_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE idamax_I + !USE idamax_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: KPASS - INTEGER , INTENT(IN) :: NUME - INTEGER , INTENT(IN) :: NEIG - INTEGER , INTENT(INOUT) :: NNCV - REAL(DOUBLE) , INTENT(IN) :: CRITE - REAL(DOUBLE) , INTENT(IN) :: CRITC - INTEGER , INTENT(IN) :: ISELEC(NEIG) - INTEGER , INTENT(OUT) :: ICV(NUME) - INTEGER , INTENT(INOUT) :: IND(NEIG) - INTEGER , INTENT(OUT) :: INCV(NEIG) - REAL(DOUBLE) , INTENT(IN) :: SVEC(KPASS*NUME) - REAL(DOUBLE) , INTENT(IN) :: EIGVAL(NUME) - REAL(DOUBLE) :: ROWLAST(NEIG) - REAL(DOUBLE) , INTENT(IN) :: OLDVAL(NUME) + INTEGER , INTENT(IN) :: KPASS + INTEGER , INTENT(IN) :: NUME + INTEGER , INTENT(IN) :: NEIG + INTEGER , INTENT(INOUT) :: NNCV + REAL(DOUBLE) , INTENT(IN) :: CRITE + REAL(DOUBLE) , INTENT(IN) :: CRITC + INTEGER , INTENT(IN) :: ISELEC(NEIG) + INTEGER , INTENT(OUT) :: ICV(NUME) + INTEGER , INTENT(INOUT) :: IND(NEIG) + INTEGER , INTENT(OUT) :: INCV(NEIG) + REAL(DOUBLE) , INTENT(IN) :: SVEC(KPASS*NUME) + REAL(DOUBLE) , INTENT(IN) :: EIGVAL(NUME) + REAL(DOUBLE) :: ROWLAST(NEIG) + REAL(DOUBLE) , INTENT(IN) :: OLDVAL(NUME) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: NNCE, I, IVAL, ICNT, ICUR, L, INDX, ITEMP - REAL(DOUBLE) :: TMAX, TEMP - LOGICAL :: DONE + INTEGER :: NNCE, I, IVAL, ICNT, ICUR, L, INDX, ITEMP + REAL(DOUBLE) :: TMAX, TEMP + LOGICAL :: DONE integer :: idamax !----------------------------------------------- !----------------------------------------------------------------------- @@ -1342,167 +1342,167 @@ LOGICAL FUNCTION TSTSEL (KPASS, NUME, NEIG, ISELEC, SVEC, EIGVAL, ICV, & ! !----------------------------------------------------------------------- ! !include 'mpif.h' - - DONE = .FALSE. + + DONE = .FALSE. ! ! Test all wanted eigenvalues for convergence under CRITE ! - NNCE = 0 - DO I = 1, NEIG - IVAL = ISELEC(I) - IF (ABS(OLDVAL(IVAL)-EIGVAL(IVAL)) < CRITE) CYCLE - NNCE = NNCE + 1 - END DO - IF (NNCE == 0) THEN -! IF (MYID == 0) WRITE (6, *) 'converged by crite' - TSTSEL = .TRUE. - RETURN - ENDIF + NNCE = 0 + DO I = 1, NEIG + IVAL = ISELEC(I) + IF (ABS(OLDVAL(IVAL)-EIGVAL(IVAL)) < CRITE) CYCLE + NNCE = NNCE + 1 + END DO + IF (NNCE == 0) THEN +! IF (MYID == 0) WRITE (6, *) 'converged by crite' + TSTSEL = .TRUE. + RETURN + ENDIF ! ! Find the maximum element of the last NNCV coefficients of unconverged ! eigenvectors. For those unconverged coefficients, put their indices ! to IND and find their number NNCV ! - ICNT = 0 - DO I = 1, NEIG + ICNT = 0 + DO I = 1, NEIG !Rasa IF (ICV(ISELEC(I)).EQ.0) THEN ! ..Find coefficient and test for convergence - ICUR = KPASS*ISELEC(I) - TMAX = ABS(SVEC(ICUR)) - DO L = 1, NNCV - 1 - TMAX = MAX(TMAX,ABS(SVEC(ICUR-L))) - END DO - IF (TMAX < CRITC) THEN + ICUR = KPASS*ISELEC(I) + TMAX = ABS(SVEC(ICUR)) + DO L = 1, NNCV - 1 + TMAX = MAX(TMAX,ABS(SVEC(ICUR-L))) + END DO + IF (TMAX < CRITC) THEN ! ..this coefficient converged - ICV(ISELEC(I)) = 1 - ELSE + ICV(ISELEC(I)) = 1 + ELSE ! ..Not converged. Add it to the list. !Rasa -- start change - ICV(ISELEC(I)) = 0 + ICV(ISELEC(I)) = 0 !Rasa -- end change - ICNT = ICNT + 1 - IND(ICNT) = ISELEC(I) - ROWLAST(ICNT) = TMAX - ENDIF + ICNT = ICNT + 1 + IND(ICNT) = ISELEC(I) + ROWLAST(ICNT) = TMAX + ENDIF !Rasa ENDIF - END DO - - NNCV = ICNT - IF (NNCV == 0) THEN - DONE = .TRUE. + END DO + + NNCV = ICNT + IF (NNCV == 0) THEN + DONE = .TRUE. !IF (NNCV.EQ.0) print*, 'converged by critc', kpass -! WRITE (6, *) 'converged by critc', KPASS, MYID - ENDIF +! WRITE (6, *) 'converged by critc', KPASS, MYID + ENDIF ! ! Sort the ROWLAST elements interchanging their indices as well ! - DO I = 1, NNCV - INDX = IDAMAX(NNCV - I + 1,ROWLAST(I),1) - INCV(I) = IND(INDX+I-1) - - TEMP = ROWLAST(INDX+I-1) - ROWLAST(INDX+I-1) = ROWLAST(I) - ROWLAST(I) = TEMP - ITEMP = IND(INDX+I-1) - IND(INDX+I-1) = IND(I) - IND(I) = ITEMP - END DO - - TSTSEL = DONE - RETURN - END FUNCTION TSTSEL + DO I = 1, NNCV + INDX = IDAMAX(NNCV - I + 1,ROWLAST(I),1) + INCV(I) = IND(INDX+I-1) + + TEMP = ROWLAST(INDX+I-1) + ROWLAST(INDX+I-1) = ROWLAST(I) + ROWLAST(I) = TEMP + ITEMP = IND(INDX+I-1) + IND(INDX+I-1) = IND(I) + IND(I) = ITEMP + END DO + + TSTSEL = DONE + RETURN + END FUNCTION TSTSEL !======================================================================= - subroutine mgs_nrm(n, kp, new, scra, b) + subroutine mgs_nrm(n, kp, new, scra, b) !======================================================================= ! Orthogonalizis the new vectors in B (from kp+1...kp+new) ! to the previous kp B vectors and to themselves ! using Modified Gram Schmidt. Then normalizes them. ! The procedure is repeated twice. !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: double -! USE mpi_C + USE vast_kind_param, ONLY: double +! USE mpi_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !use dgemv_I - !use ddot_I - !use dscal_I + !use dgemv_I + !use ddot_I + !use dscal_I implicit none !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - integer :: n - integer , intent(in) :: kp - integer :: new - real(double) :: scra(new) - real(double) :: b((kp + new)*n) + integer :: n + integer , intent(in) :: kp + integer :: new + real(double) :: scra(new) + real(double) :: b((kp + new)*n) real(kind(0.0d0)) :: ddot !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - integer :: i, newstart, kcur, k, jcur, j, mm - real(double) :: dnm + integer :: i, newstart, kcur, k, jcur, j, mm + real(double) :: dnm !----------------------------------------------- - + ! ! MODIFIED GRAM-SCHMIDT (twice) ! !if (myid.eq.0) then - do i = 1, 2 - - newstart = kp*n + 1 + do i = 1, 2 + + newstart = kp*n + 1 ! ! First record contribution from the kp vectors to the new ones. ! - kcur = 1 - do k = 1, kp - jcur = newstart + kcur = 1 + do k = 1, kp + jcur = newstart call dgemv ('T', n, new, 1.D0, b(jcur), n, b(kcur), 1, 0.D0, scra, & - 1) - do j = 1, new + 1) + do j = 1, new ! call daxpy(N,-scra(j),B(kcur),1,B(jcur),1) - do mm = 0, n - 1 - b(jcur+mm) = b(jcur+mm) - scra(j)*b(kcur+mm) - end do - jcur = jcur + n - end do - kcur = kcur + n - end do + do mm = 0, n - 1 + b(jcur+mm) = b(jcur+mm) - scra(j)*b(kcur+mm) + end do + jcur = jcur + n + end do + kcur = kcur + n + end do ! ! Then orthogonalize the new ones among themselves. ! - do k = 1, new - jcur = kcur + n + do k = 1, new + jcur = kcur + n ! The current vector should be normalized ! - dnm = ddot(n,b(kcur),1,b(kcur),1) - dnm = sqrt(dnm) - call dscal (n, 1/dnm, b(kcur), 1) + dnm = ddot(n,b(kcur),1,b(kcur),1) + dnm = sqrt(dnm) + call dscal (n, 1/dnm, b(kcur), 1) ! call dgemv ('T', n, new - k, 1.D0, b(jcur), n, b(kcur), 1, 0.D0, & - scra, 1) - do j = k + 1, new + scra, 1) + do j = k + 1, new ! call daxpy(N,-scra(j-k),B(kcur),1,B(jcur),1) - do mm = 0, n - 1 - b(jcur+mm) = b(jcur+mm) - scra(j-k)*b(kcur+mm) - end do - jcur = jcur + n - end do - kcur = kcur + n - end do - end do + do mm = 0, n - 1 + b(jcur+mm) = b(jcur+mm) - scra(j-k)*b(kcur+mm) + end do + jcur = jcur + n + end do + kcur = kcur + n + end do + end do !end if - + ! call MPI_BCAST(B,(kp+New)*n,MPI_DOUBLE_PRECISION,0, ! : MPI_COMM_WORLD,ierr) - - return - end subroutine mgs_nrm + + return + end subroutine mgs_nrm diff --git a/src/lib/libdvd90/dvdson_I.f90 b/src/lib/libdvd90/dvdson_I.f90 index 3f33a406a..cf10a7488 100644 --- a/src/lib/libdvd90/dvdson_I.f90 +++ b/src/lib/libdvd90/dvdson_I.f90 @@ -1,35 +1,35 @@ - MODULE dvdson_I + MODULE dvdson_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE dvdson (IRC, IREV, N, LIM, NOC, ILOW, IHIGH, ISELEC, NIV& , MBLOCK, CRITE, CRITC, CRITR, MAXITER, WORK, IWRSZ, IWORK, IIWSZ& - , HIEND, NLOOPS, IERR) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(INOUT) :: IRC - INTEGER, DIMENSION(*), INTENT(INOUT) :: IREV - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: LIM - INTEGER, INTENT(IN) :: NOC - INTEGER, INTENT(INOUT) :: ILOW - INTEGER, INTENT(INOUT) :: IHIGH - INTEGER, DIMENSION(LIM), INTENT(INOUT) :: ISELEC - INTEGER, INTENT(IN) :: NIV - INTEGER, INTENT(IN) :: MBLOCK - REAL(DOUBLE) :: CRITE - REAL(DOUBLE) :: CRITC - REAL(DOUBLE) :: CRITR - INTEGER :: MAXITER - REAL(DOUBLE), DIMENSION(IWRSZ) :: WORK - INTEGER, INTENT(IN) :: IWRSZ - INTEGER, DIMENSION(IIWSZ) :: IWORK - INTEGER, INTENT(IN) :: IIWSZ - LOGICAL, INTENT(INOUT) :: HIEND - INTEGER, INTENT(OUT) :: NLOOPS - INTEGER, INTENT(INOUT) :: IERR + , HIEND, NLOOPS, IERR) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(INOUT) :: IRC + INTEGER, DIMENSION(*), INTENT(INOUT) :: IREV + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: LIM + INTEGER, INTENT(IN) :: NOC + INTEGER, INTENT(INOUT) :: ILOW + INTEGER, INTENT(INOUT) :: IHIGH + INTEGER, DIMENSION(LIM), INTENT(INOUT) :: ISELEC + INTEGER, INTENT(IN) :: NIV + INTEGER, INTENT(IN) :: MBLOCK + REAL(DOUBLE) :: CRITE + REAL(DOUBLE) :: CRITC + REAL(DOUBLE) :: CRITR + INTEGER :: MAXITER + REAL(DOUBLE), DIMENSION(IWRSZ) :: WORK + INTEGER, INTENT(IN) :: IWRSZ + INTEGER, DIMENSION(IIWSZ) :: IWORK + INTEGER, INTENT(IN) :: IIWSZ + LOGICAL, INTENT(INOUT) :: HIEND + INTEGER, INTENT(OUT) :: NLOOPS + INTEGER, INTENT(INOUT) :: IERR !VAST...Calls: INITDVD, DVDRVR, DSCAL, DCOPY !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/gdvd.f90 b/src/lib/libdvd90/gdvd.f90 index 75087bc47..1a2ab8517 100644 --- a/src/lib/libdvd90/gdvd.f90 +++ b/src/lib/libdvd90/gdvd.f90 @@ -1,147 +1,147 @@ - + !*************************************************************************** - + SUBROUTINE GDVD(OP, N, LIM, DIAG, ILOW, IHIGH, ISELEC, NIV, MBLOCK, CRITE& , CRITC, CRITR, ORTHO, MAXITER, WORK, IWRSZ, IWORK, IIWSZ, HIEND, & - NLOOPS, NMV, IERR) + NLOOPS, NMV, IERR) ! Written by M. Saparov ! ! Note: ! HIEND, ISELEC() not used outside dvdson !*************************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE op_I - USE dvdson_I + !USE op_I + USE dvdson_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER :: N - INTEGER :: LIM - INTEGER :: ILOW - INTEGER :: IHIGH - INTEGER :: NIV - INTEGER :: MBLOCK - INTEGER :: MAXITER - INTEGER :: IWRSZ - INTEGER :: IIWSZ - INTEGER :: NLOOPS - INTEGER, INTENT(OUT) :: NMV - INTEGER :: IERR - REAL(DOUBLE) :: CRITE - REAL(DOUBLE) :: CRITC - REAL(DOUBLE) :: CRITR - REAL(DOUBLE) :: ORTHO - LOGICAL :: HIEND - INTEGER :: ISELEC(LIM) - INTEGER :: IWORK(IIWSZ) + INTEGER :: N + INTEGER :: LIM + INTEGER :: ILOW + INTEGER :: IHIGH + INTEGER :: NIV + INTEGER :: MBLOCK + INTEGER :: MAXITER + INTEGER :: IWRSZ + INTEGER :: IIWSZ + INTEGER :: NLOOPS + INTEGER, INTENT(OUT) :: NMV + INTEGER :: IERR + REAL(DOUBLE) :: CRITE + REAL(DOUBLE) :: CRITC + REAL(DOUBLE) :: CRITR + REAL(DOUBLE) :: ORTHO + LOGICAL :: HIEND + INTEGER :: ISELEC(LIM) + INTEGER :: IWORK(IIWSZ) real(DOUBLE), DIMENSION(N), INTENT(INOUT) :: DIAG - REAL(DOUBLE) :: WORK(IWRSZ) + REAL(DOUBLE) :: WORK(IWRSZ) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER, DIMENSION(7) :: IREV - INTEGER :: NOC, IRC, NB, IW1, IW2, IW3, IIW, IIN, IW4, ICUR, I, INDX, J - REAL(DOUBLE) :: VALUE, OVALUE, RNORM, EPSIL + INTEGER, DIMENSION(7) :: IREV + INTEGER :: NOC, IRC, NB, IW1, IW2, IW3, IIW, IIN, IW4, ICUR, I, INDX, J + REAL(DOUBLE) :: VALUE, OVALUE, RNORM, EPSIL ! !********************************************************************** ! NOC = number of orthogonalization constraints ! IRC = reverse communication switch - - NOC = 0 - IRC = 0 - + + NOC = 0 + IRC = 0 + !*********************************************************************** ! CALLING DAVIDSON with reverse communication !*********************************************************************** ! Initial estimates ! - IF (NIV == 0) THEN - WRITE (6, *) 'GDVD Error : No initial estimate!!!' - IERR = -1000 - RETURN - ENDIF - + IF (NIV == 0) THEN + WRITE (6, *) 'GDVD Error : No initial estimate!!!' + IERR = -1000 + RETURN + ENDIF + !ttt=etime_(tarray) - NMV = 0 + NMV = 0 !xhh print*, 'MBLOCK = ', mblock !xhh print *, ' gdvd: niv = ', niv - 99 CONTINUE + 99 CONTINUE CALL DVDSON (IRC, IREV, N, LIM, NOC, ILOW, IHIGH, ISELEC, NIV, MBLOCK, & CRITE, CRITC, CRITR, MAXITER, WORK, IWRSZ, IWORK, IIWSZ, HIEND, NLOOPS& - , IERR) + , IERR) ! ! * * Start Reverse Communication * * * * * * * * * * * * * * * * * * * ! - NB = IREV(1) - IW1 = IREV(2) - IW2 = IREV(3) - IW3 = IREV(4) - IIW = IREV(5) - IIN = IREV(6) - IW4 = IREV(7) - - IF (IRC == 1) THEN + NB = IREV(1) + IW1 = IREV(2) + IW2 = IREV(3) + IW3 = IREV(4) + IIW = IREV(5) + IIN = IREV(6) + IW4 = IREV(7) + + IF (IRC == 1) THEN !********* ..Preconditioning. Solve NB times(M work(iw2)=work(iw1)) ! ..Results always on work(iw2) - - ICUR = 0 - DO I = 1, NB - INDX = IWORK(IIW+I-1) - 1 - VALUE = WORK(IW3+INDX) - OVALUE = WORK(IW4+INDX) - RNORM = WORK(IIN+INDX) - EPSIL = WORK(IIN+LIM+INDX) + + ICUR = 0 + DO I = 1, NB + INDX = IWORK(IIW+I-1) - 1 + VALUE = WORK(IW3+INDX) + OVALUE = WORK(IW4+INDX) + RNORM = WORK(IIN+INDX) + EPSIL = WORK(IIN+LIM+INDX) ! The current approximation of the eigenvector is x=Bc ! If needed it should be saved e.g: call dcopy(N,work(iw2),1,curx,1) - + ! write(*,11) nloops,value,rnorm - 11 FORMAT('It ',I4,' Dl',D10.3,' Res:',D10.3) + 11 FORMAT('It ',I4,' Dl',D10.3,' Res:',D10.3) ! !------------- ! (M-lI) .. Compute temporarily (M-valueI) (M preconditioner) ! .. Needed for (M-valueI)^-1 res ! .. Here M is the DIAG - DIAG(:N) = DIAG(:N) - VALUE + DIAG(:N) = DIAG(:N) - VALUE !------------- !* Choice of Diagonal preconditioning - DO J = 1, N - IF (ABS(DIAG(J)) > 1.0D-06) THEN - WORK(IW2+ICUR+J-1) = WORK(IW1+ICUR+J-1)/DIAG(J) - ELSE - WORK(IW2+ICUR+J-1) = WORK(IW1+ICUR+J-1)*1.0D06 - ENDIF - END DO + DO J = 1, N + IF (ABS(DIAG(J)) > 1.0D-06) THEN + WORK(IW2+ICUR+J-1) = WORK(IW1+ICUR+J-1)/DIAG(J) + ELSE + WORK(IW2+ICUR+J-1) = WORK(IW1+ICUR+J-1)*1.0D06 + ENDIF + END DO !*------------- !* e.g: For No preconditioner: Lanczos !* call dcopy(N,WORK(iw1+icur),1,WORK(iw2+icur),1) !*------------- !* (M+lI) .. Restore (M+valueI) - DIAG(:N) = DIAG(:N) + VALUE - - ICUR = ICUR + N - END DO - - GO TO 99 - + DIAG(:N) = DIAG(:N) + VALUE + + ICUR = ICUR + N + END DO + + GO TO 99 + !********* - ELSE IF (IRC==2 .OR. IRC==3) THEN + ELSE IF (IRC==2 .OR. IRC==3) THEN !********* ..Matrix-vector multiply. - CALL OP (N, NB, WORK(IW1), WORK(IW2)) - NMV = NMV + NB - - GO TO 99 - ENDIF + CALL OP (N, NB, WORK(IW1), WORK(IW2)) + NMV = NMV + NB + + GO TO 99 + ENDIF ! * * * * End of Reverse Communication * * * * * * * * * * * * * * * * * - - RETURN - END SUBROUTINE GDVD + + RETURN + END SUBROUTINE GDVD diff --git a/src/lib/libdvd90/gdvd_I.f90 b/src/lib/libdvd90/gdvd_I.f90 index 37313861a..67d6eec4b 100644 --- a/src/lib/libdvd90/gdvd_I.f90 +++ b/src/lib/libdvd90/gdvd_I.f90 @@ -1,37 +1,37 @@ - MODULE gdvd_I + MODULE gdvd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE gdvd (OP, N, LIM, DIAG, ILOW, IHIGH, ISELEC, NIV, MBLOCK& , CRITE, CRITC, CRITR, ORTHO, MAXITER, WORK, IWRSZ, IWORK, IIWSZ& - , HIEND, NLOOPS, NMV, IERR) - USE vast_kind_param,ONLY: DOUBLE - EXTERNAL OP - integer, INTENT(IN) :: N - integer, INTENT(IN) :: LIM - real(DOUBLE), DIMENSION(N), INTENT(INOUT) :: DIAG - integer :: ILOW - integer :: IHIGH - integer, DIMENSION(LIM) :: ISELEC - integer, INTENT(IN) :: NIV - integer :: MBLOCK - real(DOUBLE) :: CRITE - real(DOUBLE) :: CRITC - real(DOUBLE) :: CRITR - real(DOUBLE) :: ORTHO + , HIEND, NLOOPS, NMV, IERR) + USE vast_kind_param,ONLY: DOUBLE + EXTERNAL OP + integer, INTENT(IN) :: N + integer, INTENT(IN) :: LIM + real(DOUBLE), DIMENSION(N), INTENT(INOUT) :: DIAG + integer :: ILOW + integer :: IHIGH + integer, DIMENSION(LIM) :: ISELEC + integer, INTENT(IN) :: NIV + integer :: MBLOCK + real(DOUBLE) :: CRITE + real(DOUBLE) :: CRITC + real(DOUBLE) :: CRITR + real(DOUBLE) :: ORTHO !VAST...Dummy argument ORTHO is not referenced in this routine. - integer :: MAXITER - real(DOUBLE), DIMENSION(IWRSZ), INTENT(INOUT) :: WORK - integer, INTENT(IN) :: IWRSZ - integer, DIMENSION(IIWSZ), INTENT(IN) :: IWORK - integer, INTENT(IN) :: IIWSZ - logical :: HIEND - integer :: NLOOPS - integer, INTENT(OUT) :: NMV - integer, INTENT(OUT) :: IERR + integer :: MAXITER + real(DOUBLE), DIMENSION(IWRSZ), INTENT(INOUT) :: WORK + integer, INTENT(IN) :: IWRSZ + integer, DIMENSION(IIWSZ), INTENT(IN) :: IWORK + integer, INTENT(IN) :: IIWSZ + logical :: HIEND + integer :: NLOOPS + integer, INTENT(OUT) :: NMV + integer, INTENT(OUT) :: IERR !VAST...Calls: OP, DVDSON !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/iniest.f90 b/src/lib/libdvd90/iniest.f90 index 18aec3fab..ecc996629 100644 --- a/src/lib/libdvd90/iniest.f90 +++ b/src/lib/libdvd90/iniest.f90 @@ -1,4 +1,4 @@ - SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) + SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) !----------------------------------------------------------------------- ! Routine for providing initial estimates from the diagonal ! of the matrix. This way was used by Dvdson in atomic structure @@ -6,40 +6,40 @@ SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) ! else is available. ! !----------------------------------------------------------------------- -!...Translated by Pacific-Sierra Research 77to90 4.3E 18:15:59 2/21/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 18:15:59 2/21/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - !USE dinit_I - !USE dspevx_I - !USE vec_I - !USE dcopy_I + !USE dinit_I + !USE dspevx_I + !USE vec_I + !USE dcopy_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: NB - INTEGER :: NIV - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: JCOL(0:*) - INTEGER, INTENT(IN) :: IROW(*) - INTEGER, INTENT(IN) :: IBLOCK(*) - REAL(DOUBLE), INTENT(IN) :: HMX(*) - REAL(DOUBLE) :: BASIS(*) + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: NB + INTEGER :: NIV + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: JCOL(0:*) + INTEGER, INTENT(IN) :: IROW(*) + INTEGER, INTENT(IN) :: IBLOCK(*) + REAL(DOUBLE), INTENT(IN) :: HMX(*) + REAL(DOUBLE) :: BASIS(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NS, ICOUNT, & - J, ISTART, ISH, II, NFOUND, INFO, IERR, IC - !REAL(DOUBLE) :: EIGVAL, WORK + J, ISTART, ISH, II, NFOUND, INFO, IERR, IC + !REAL(DOUBLE) :: EIGVAL, WORK integer, dimension(:), pointer :: iqiwork,iqif,iqjsh integer, dimension(:), allocatable, target :: iwork, ifail, jsh @@ -50,103 +50,103 @@ SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) ! !pointer (iqap,ap(1)),(iqeig,eigval(1)),(iqvec,vec(1)) ! !pointer (iqwork,work(1)),(iqiwork,iwork(1)),(iqif,IFAIL(1)) ! !pointer (iqjsh,jsh(1)) - + !****************************************************************** - + !***** alloc space for 100*100 lower triangular - NS = MIN(1000,NB) + NS = MIN(1000,NB) !once here NS = min(800, NB) !print*, 'NS=',NS,' NIV=',NIV - !CALL ALLOC (IQAP, NS*(NS + 1)/2, 8) + !CALL ALLOC (IQAP, NS*(NS + 1)/2, 8) allocate (ap(NS*(NS + 1)/2),stat=ierr) if (ierr.ne.0) call mem_fail(6,NS*(NS + 1)/2,'iniest::ap',ierr); iqap=>ap - CALL DINIT (NS*(NS + 1)/2, 0.D0, AP, 1) - - !CALL ALLOC (IQEIG, NS, 8) + CALL DINIT (NS*(NS + 1)/2, 0.D0, AP, 1) + + !CALL ALLOC (IQEIG, NS, 8) allocate (eigval(NS),stat=ierr) if (ierr.ne.0) call mem_fail(6,ns,'iniest::eigval',ierr); IQEIG=>eigval - !CALL ALLOC (IQVEC, NS*NIV, 8) + !CALL ALLOC (IQVEC, NS*NIV, 8) allocate (vec(NS*NIV),stat=ierr) if (ierr.ne.0) call mem_fail(6,ns*niv,'iniest::vec',ierr); IQVEC=>vec - !CALL ALLOC (IQWORK, 8*NS, 8) + !CALL ALLOC (IQWORK, 8*NS, 8) allocate (work(8*NS),stat=ierr) if (ierr.ne.0) call mem_fail(6,8*NS,'iniest::work',ierr); IQWORK=>work - !CALL ALLOC (IQIWORK, 5*NS, 4) + !CALL ALLOC (IQIWORK, 5*NS, 4) allocate (iwork(5*NS),stat=ierr) if (ierr.ne.0) call mem_fail(6,5*NS,'iniest::iwork',ierr); IQIWORK=>iwork - !CALL ALLOC (IQIF, NS, 4) + !CALL ALLOC (IQIF, NS, 4) allocate (ifail(ns),stat=ierr) if (ierr.ne.0) call mem_fail(6,ns,'iniest::IFAIL',ierr); iqif=>ifail - !CALL ALLOC (IQJSH, NS, 4) + !CALL ALLOC (IQJSH, NS, 4) allocate (jsh(NS),stat=ierr) if (ierr.ne.0) call mem_fail(6,ns,'iniest::jsh',ierr); iqjsh=>jsh - ICOUNT = 0 - + ICOUNT = 0 + !**** separate upper left block of size NS*NS - DO J = 1, N - IF (ICOUNT >= NS) EXIT - IF (IBLOCK(J) /= JBLOCK) CYCLE - ICOUNT = ICOUNT + 1 - JSH(ICOUNT) = J - ISTART = JCOL(J-1) + 1 - ISH = J - ICOUNT - 100 CONTINUE - AP(IROW(ISTART)-ISH+(ICOUNT-1)*(2*NS-ICOUNT)/2) = HMX(ISTART) + DO J = 1, N + IF (ICOUNT >= NS) EXIT + IF (IBLOCK(J) /= JBLOCK) CYCLE + ICOUNT = ICOUNT + 1 + JSH(ICOUNT) = J + ISTART = JCOL(J-1) + 1 + ISH = J - ICOUNT + 100 CONTINUE + AP(IROW(ISTART)-ISH+(ICOUNT-1)*(2*NS-ICOUNT)/2) = HMX(ISTART) ! print*, 'ic = ',icount, ' i=', irow(istart)-ish - ISTART = ISTART + 1 + ISTART = ISTART + 1 ! check the block structure for zero elements - IF (ISTART > JCOL(J)) GO TO 102 - ISH = ISH + COUNT(IBLOCK(IROW(ISTART-1):IROW(ISTART))/=JBLOCK) - IF (ISTART > JCOL(J)) GO TO 102 - IF (IROW(ISTART) - ISH <= NS) GO TO 100 + IF (ISTART > JCOL(J)) GO TO 102 + ISH = ISH + COUNT(IBLOCK(IROW(ISTART-1):IROW(ISTART))/=JBLOCK) + IF (ISTART > JCOL(J)) GO TO 102 + IF (IROW(ISTART) - ISH <= NS) GO TO 100 ! goto 100 - 102 CONTINUE - END DO + 102 CONTINUE + END DO CALL DSPEVX ('Vectors also', 'In a range', 'Lower triangular', NS, AP, & -1., -1., 1, NIV, 0.D0, NFOUND, EIGVAL, VEC, NS, WORK, IWORK, IFAIL, & - INFO) - IERR = -ABS(INFO) - IF (IERR /= 0) WRITE (6, *) 'iniest ierr =', IERR + INFO) + IERR = -ABS(INFO) + IF (IERR /= 0) WRITE (6, *) 'iniest ierr =', IERR ! print '(D14.7,X,I2)', (eigval(i),i, i=1,NIV) - + !****************************************************************** - - + + ! ! ..Build the Basis. ! - CALL DINIT (N*NIV, 0.D0, BASIS, 1) - ISTART = 0 - DO J = 1, NIV + CALL DINIT (N*NIV, 0.D0, BASIS, 1) + ISTART = 0 + DO J = 1, NIV !scatter the vectors - DO IC = 1, NS - BASIS(ISTART+JSH(IC)) = VEC((J - 1)*NS + IC) - END DO + DO IC = 1, NS + BASIS(ISTART+JSH(IC)) = VEC((J - 1)*NS + IC) + END DO ! call dcopy(NS,vec((J-1)*NS+1),1,BASIS(istart+ish(j)),1) - ISTART = ISTART + N - END DO - CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*N+1), 1) - deallocate(ap) !CALL DALLOC (IQAP) - deallocate(eigval) !CALL DALLOC (IQEIG) - deallocate(vec) !CALL DALLOC (IQVEC) - deallocate(work) !CALL DALLOC (IQWORK) - deallocate(iwork) !CALL DALLOC (IQIWORK) - deallocate(ifail) !CALL DALLOC (IQIF) - deallocate(jsh) !CALL DALLOC (IQJSH) - - RETURN - END SUBROUTINE INIEST + ISTART = ISTART + N + END DO + CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*N+1), 1) + deallocate(ap) !CALL DALLOC (IQAP) + deallocate(eigval) !CALL DALLOC (IQEIG) + deallocate(vec) !CALL DALLOC (IQVEC) + deallocate(work) !CALL DALLOC (IQWORK) + deallocate(iwork) !CALL DALLOC (IQIWORK) + deallocate(ifail) !CALL DALLOC (IQIF) + deallocate(jsh) !CALL DALLOC (IQJSH) + + RETURN + END SUBROUTINE INIEST diff --git a/src/lib/libdvd90/iniest_I.f90 b/src/lib/libdvd90/iniest_I.f90 index 2c0ddc9d6..e9dd2eae0 100644 --- a/src/lib/libdvd90/iniest_I.f90 +++ b/src/lib/libdvd90/iniest_I.f90 @@ -1,24 +1,24 @@ MODULE iniest_I INTERFACE ! - SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer + SUBROUTINE INIEST(N, NB, NIV, HMX, JCOL, IROW, BASIS, IBLOCK, JBLOCK) +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: NB - INTEGER :: NIV - INTEGER, INTENT(IN) :: JBLOCK - INTEGER, INTENT(IN) :: JCOL(0:*) - INTEGER, INTENT(IN) :: IROW(*) - INTEGER, INTENT(IN) :: IBLOCK(*) - REAL(DOUBLE), INTENT(IN) :: HMX(*) - REAL(DOUBLE) :: BASIS(*) + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: NB + INTEGER :: NIV + INTEGER, INTENT(IN) :: JBLOCK + INTEGER, INTENT(IN) :: JCOL(0:*) + INTEGER, INTENT(IN) :: IROW(*) + INTEGER, INTENT(IN) :: IBLOCK(*) + REAL(DOUBLE), INTENT(IN) :: HMX(*) + REAL(DOUBLE) :: BASIS(*) END SUBROUTINE END INTERFACE END MODULE diff --git a/src/lib/libdvd90/initdvd_I.f90 b/src/lib/libdvd90/initdvd_I.f90 index b297155fd..f03822948 100644 --- a/src/lib/libdvd90/initdvd_I.f90 +++ b/src/lib/libdvd90/initdvd_I.f90 @@ -1,25 +1,25 @@ - MODULE initdvd_I + MODULE initdvd_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE initdvd (IRC, IREV, N, NOC, NIV, NUME, LIM, HIEND, SCRA1& - , ORTHOBASIS, BASIS, AB, S) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(INOUT) :: IRC - INTEGER, DIMENSION(*), INTENT(OUT) :: IREV - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: NOC - INTEGER, INTENT(INOUT) :: NIV - INTEGER, INTENT(IN) :: NUME - INTEGER, INTENT(IN) :: LIM - LOGICAL, INTENT(IN) :: HIEND - REAL(DOUBLE), DIMENSION(*) :: SCRA1 - REAL(DOUBLE), DIMENSION(N*(NOC + LIM)) :: ORTHOBASIS - REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS - REAL(DOUBLE), DIMENSION(N*LIM) :: AB - REAL(DOUBLE), DIMENSION(*) :: S + , ORTHOBASIS, BASIS, AB, S) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(INOUT) :: IRC + INTEGER, DIMENSION(*), INTENT(OUT) :: IREV + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: NOC + INTEGER, INTENT(INOUT) :: NIV + INTEGER, INTENT(IN) :: NUME + INTEGER, INTENT(IN) :: LIM + LOGICAL, INTENT(IN) :: HIEND + REAL(DOUBLE), DIMENSION(*) :: SCRA1 + REAL(DOUBLE), DIMENSION(N*(NOC + LIM)) :: ORTHOBASIS + REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS + REAL(DOUBLE), DIMENSION(N*LIM) :: AB + REAL(DOUBLE), DIMENSION(*) :: S !VAST...Calls: DINIT, DCOPY, MGS_NRM, DSCAL, ADDS - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/mgs_nrm_I.f90 b/src/lib/libdvd90/mgs_nrm_I.f90 index b7fadcc1e..0fa85b8d9 100644 --- a/src/lib/libdvd90/mgs_nrm_I.f90 +++ b/src/lib/libdvd90/mgs_nrm_I.f90 @@ -1,16 +1,16 @@ - MODULE mgs_nrm_I + MODULE mgs_nrm_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE mgs_nrm (N, KP, NEW, SCRA, B) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: KP - INTEGER, INTENT(IN) :: NEW - REAL(DOUBLE), DIMENSION(NEW), INTENT(IN) :: SCRA - REAL(DOUBLE), DIMENSION((KP + NEW)*N), INTENT(INOUT) :: B + SUBROUTINE mgs_nrm (N, KP, NEW, SCRA, B) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: KP + INTEGER, INTENT(IN) :: NEW + REAL(DOUBLE), DIMENSION(NEW), INTENT(IN) :: SCRA + REAL(DOUBLE), DIMENSION((KP + NEW)*N), INTENT(INOUT) :: B !VAST...Calls: DGEMV, DDOT, DSCAL - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/multbc_I.f90 b/src/lib/libdvd90/multbc_I.f90 index 889a4ee37..a397d42d0 100644 --- a/src/lib/libdvd90/multbc_I.f90 +++ b/src/lib/libdvd90/multbc_I.f90 @@ -1,17 +1,17 @@ - MODULE multbc_I + MODULE multbc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE multbc (N, K, M, C, TEMP, B) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(K*M) :: C - REAL(DOUBLE), DIMENSION(M) :: TEMP - REAL(DOUBLE), DIMENSION(N*K) :: B + SUBROUTINE multbc (N, K, M, C, TEMP, B) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(K*M) :: C + REAL(DOUBLE), DIMENSION(M) :: TEMP + REAL(DOUBLE), DIMENSION(N*K) :: B !VAST...Calls: DGEMV, DCOPY - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/newvec_I.f90 b/src/lib/libdvd90/newvec_I.f90 index 4fc9f4b8a..37ca8c39d 100644 --- a/src/lib/libdvd90/newvec_I.f90 +++ b/src/lib/libdvd90/newvec_I.f90 @@ -1,31 +1,31 @@ - MODULE newvec_I + MODULE newvec_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE newvec (N, NUME, LIM, MBLOCK, KPASS, CRITR, NNCV, INCV, SVEC& - , EIGVAL, OLDVAL, AB, BASIS, ICV, SCRA1, EPSIL, DONE) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: NUME - INTEGER, INTENT(IN) :: LIM - INTEGER, INTENT(IN) :: MBLOCK - INTEGER, INTENT(IN) :: KPASS - REAL(DOUBLE), INTENT(IN) :: CRITR - INTEGER, INTENT(INOUT) :: NNCV - INTEGER, DIMENSION(NUME), INTENT(INOUT) :: INCV - REAL(DOUBLE), DIMENSION(LIM*NUME) :: SVEC - REAL(DOUBLE), DIMENSION(LIM), INTENT(IN) :: EIGVAL - REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: OLDVAL - REAL(DOUBLE), DIMENSION(N*LIM) :: AB - REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS - INTEGER, DIMENSION(NUME), INTENT(OUT) :: ICV - REAL(DOUBLE), DIMENSION(LIM), INTENT(INOUT) :: SCRA1 - REAL(DOUBLE), DIMENSION(LIM), INTENT(OUT) :: EPSIL - LOGICAL, INTENT(OUT) :: DONE + , EIGVAL, OLDVAL, AB, BASIS, ICV, SCRA1, EPSIL, DONE) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: NUME + INTEGER, INTENT(IN) :: LIM + INTEGER, INTENT(IN) :: MBLOCK + INTEGER, INTENT(IN) :: KPASS + REAL(DOUBLE), INTENT(IN) :: CRITR + INTEGER, INTENT(INOUT) :: NNCV + INTEGER, DIMENSION(NUME), INTENT(INOUT) :: INCV + REAL(DOUBLE), DIMENSION(LIM*NUME) :: SVEC + REAL(DOUBLE), DIMENSION(LIM), INTENT(IN) :: EIGVAL + REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: OLDVAL + REAL(DOUBLE), DIMENSION(N*LIM) :: AB + REAL(DOUBLE), DIMENSION(N*LIM) :: BASIS + INTEGER, DIMENSION(NUME), INTENT(OUT) :: ICV + REAL(DOUBLE), DIMENSION(LIM), INTENT(INOUT) :: SCRA1 + REAL(DOUBLE), DIMENSION(LIM), INTENT(OUT) :: EPSIL + LOGICAL, INTENT(OUT) :: DONE !VAST.../MPI/ MYID(IN) !VAST...Calls: DGEMV, DAXPY, DDOT !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/ovflow_I.f90 b/src/lib/libdvd90/ovflow_I.f90 index 74f1216c5..8e3d36bed 100644 --- a/src/lib/libdvd90/ovflow_I.f90 +++ b/src/lib/libdvd90/ovflow_I.f90 @@ -1,20 +1,20 @@ - MODULE ovflow_I + MODULE ovflow_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE ovflow (N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: NUME - INTEGER, INTENT(INOUT) :: KPASS + SUBROUTINE ovflow (N, NUME, KPASS, SCRA1, BASIS, AB, S, SVEC, EIGVAL) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: NUME + INTEGER, INTENT(INOUT) :: KPASS !CFF .. added dimension to scra1 - REAL(DOUBLE) :: SCRA1(NUME) - REAL(DOUBLE), DIMENSION(N*KPASS) :: BASIS - REAL(DOUBLE), DIMENSION(N*KPASS) :: AB - REAL(DOUBLE), DIMENSION((KPASS*(KPASS + 1))/2), INTENT(OUT) :: S - REAL(DOUBLE), DIMENSION(KPASS), INTENT(IN) :: EIGVAL + REAL(DOUBLE) :: SCRA1(NUME) + REAL(DOUBLE), DIMENSION(N*KPASS) :: BASIS + REAL(DOUBLE), DIMENSION(N*KPASS) :: AB + REAL(DOUBLE), DIMENSION((KPASS*(KPASS + 1))/2), INTENT(OUT) :: S + REAL(DOUBLE), DIMENSION(KPASS), INTENT(IN) :: EIGVAL !VAST...Calls: MULTBC, DINIT - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libdvd90/tstsel_I.f90 b/src/lib/libdvd90/tstsel_I.f90 index 1f7ea1a8b..c93260c75 100644 --- a/src/lib/libdvd90/tstsel_I.f90 +++ b/src/lib/libdvd90/tstsel_I.f90 @@ -1,28 +1,28 @@ - MODULE tstsel_I + MODULE tstsel_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 20:12:31 2/12/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 LOGICAL FUNCTION tstsel (KPASS, NUME, NEIG, ISELEC, SVEC, EIGVAL, ICV& - , CRITE, CRITC, ROWLAST, IND, OLDVAL, NNCV, INCV) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: KPASS - INTEGER, INTENT(IN) :: NUME - INTEGER, INTENT(IN) :: NEIG - INTEGER, DIMENSION(NEIG), INTENT(IN) :: ISELEC - REAL(DOUBLE), DIMENSION(KPASS*NUME), INTENT(IN) :: SVEC - REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: EIGVAL - INTEGER, DIMENSION(NUME), INTENT(OUT) :: ICV - REAL(DOUBLE), INTENT(IN) :: CRITE - REAL(DOUBLE), INTENT(IN) :: CRITC - REAL(DOUBLE), DIMENSION(NEIG), INTENT(INOUT) :: ROWLAST - INTEGER, DIMENSION(NEIG), INTENT(INOUT) :: IND - REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: OLDVAL - INTEGER, INTENT(INOUT) :: NNCV - INTEGER, DIMENSION(NEIG), INTENT(OUT) :: INCV + , CRITE, CRITC, ROWLAST, IND, OLDVAL, NNCV, INCV) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: KPASS + INTEGER, INTENT(IN) :: NUME + INTEGER, INTENT(IN) :: NEIG + INTEGER, DIMENSION(NEIG), INTENT(IN) :: ISELEC + REAL(DOUBLE), DIMENSION(KPASS*NUME), INTENT(IN) :: SVEC + REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: EIGVAL + INTEGER, DIMENSION(NUME), INTENT(OUT) :: ICV + REAL(DOUBLE), INTENT(IN) :: CRITE + REAL(DOUBLE), INTENT(IN) :: CRITC + REAL(DOUBLE), DIMENSION(NEIG), INTENT(INOUT) :: ROWLAST + INTEGER, DIMENSION(NEIG), INTENT(INOUT) :: IND + REAL(DOUBLE), DIMENSION(NUME), INTENT(IN) :: OLDVAL + INTEGER, INTENT(INOUT) :: NNCV + INTEGER, DIMENSION(NEIG), INTENT(OUT) :: INCV !VAST.../MPI/ MYID(IN) !VAST...Calls: IDAMAX !...This routine performs I/O. - END FUNCTION - END INTERFACE - END MODULE + END FUNCTION + END INTERFACE + END MODULE diff --git a/src/lib/libmcp90/Makefile b/src/lib/libmcp90/Makefile old mode 100755 new mode 100644 diff --git a/src/lib/libmcp90/cxk.f90 b/src/lib/libmcp90/cxk.f90 index 779afadc5..6c3836617 100644 --- a/src/lib/libmcp90/cxk.f90 +++ b/src/lib/libmcp90/cxk.f90 @@ -3,8 +3,8 @@ SUBROUTINE CXK (S,IS,KAPS,NU,K,IBR,IEX) ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- ! M o d u l e s diff --git a/src/lib/libmcp90/cxk_I.f90 b/src/lib/libmcp90/cxk_I.f90 index 874786d39..e1ac75318 100644 --- a/src/lib/libmcp90/cxk_I.f90 +++ b/src/lib/libmcp90/cxk_I.f90 @@ -1,19 +1,19 @@ - MODULE cxk_I + MODULE cxk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) - USE vast_kind_param,ONLY: DOUBLE - REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: IBR - INTEGER, INTENT(IN) :: IEX + SUBROUTINE cxk (S, IS, KAPS, NU, K, IBR, IEX) + USE vast_kind_param,ONLY: DOUBLE + REAL(DOUBLE), DIMENSION(12), INTENT(INOUT) :: S + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: IBR + INTEGER, INTENT(IN) :: IEX !VAST...Calls: CRE !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libmcp90/talk.f90 b/src/lib/libmcp90/talk.f90 index e9b9c5760..6e85a0647 100644 --- a/src/lib/libmcp90/talk.f90 +++ b/src/lib/libmcp90/talk.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! * ! Print coefficients and integral parameters if IBUG1 > 0 and * ! write to disk. * @@ -8,58 +8,58 @@ SUBROUTINE TALK(JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) ! Last update: 14 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: KEYORB - USE BUFFER_C + USE BUFFER_C USE debug_C USE orb_C !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE alcbuf_I + USE alcbuf_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF + INTEGER, INTENT(IN) :: JA, JB, NU, IA, IB, IC, ID, ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF !----------------------------------------------- ! L o c a l P a r a m e t e r s !----------------------------------------------- - INTEGER, PARAMETER :: KEY = KEYORB + INTEGER, PARAMETER :: KEY = KEYORB !----------------------------------------------- ! Print coefficient if requested ! IF (IBUG1 /= 0) WRITE (99, 300) JA, JB, NP(IA), NH(IA), NP(IB), NH(IB), & - NP(IC), NH(IC), NP(ID), NH(ID), NU, ITYPE, COEF + NP(IC), NH(IC), NP(ID), NH(ID), NU, ITYPE, COEF ! ! Increment counter ! - NVCOEF = NVCOEF + 1 + NVCOEF = NVCOEF + 1 ! ! Ensure that arrays are of adequate size; reallocate if necessary ! - IF (NVCOEF > NBDIM) CALL ALCBUF (2) + IF (NVCOEF > NBDIM) CALL ALCBUF (2) ! ! Store integral indices and coefficient in COMMON/BUFFER/ ! - LABEL(1,NVCOEF) = IA - LABEL(2,NVCOEF) = IB - LABEL(3,NVCOEF) = IC - LABEL(4,NVCOEF) = ID - LABEL(5,NVCOEF) = NU - LABEL(6,NVCOEF) = ITYPE - COEFF(NVCOEF) = COEF + LABEL(1,NVCOEF) = IA + LABEL(2,NVCOEF) = IB + LABEL(3,NVCOEF) = IC + LABEL(4,NVCOEF) = ID + LABEL(5,NVCOEF) = NU + LABEL(6,NVCOEF) = ITYPE + COEFF(NVCOEF) = COEF ! - RETURN + RETURN ! - 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) - RETURN + 300 FORMAT(2(1X,1I2),4(1X,I2,A2),1X,1I2,1X,1I2,1X,1P,D19.12) + RETURN ! - END SUBROUTINE TALK + END SUBROUTINE TALK diff --git a/src/lib/libmcp90/talk_I.f90 b/src/lib/libmcp90/talk_I.f90 index ed30d6c27..93ffa9ea6 100644 --- a/src/lib/libmcp90/talk_I.f90 +++ b/src/lib/libmcp90/talk_I.f90 @@ -1,25 +1,25 @@ - MODULE talk_I + MODULE talk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 15:16:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) - USE vast_kind_param,ONLY: DOUBLE - INTEGER, INTENT(IN) :: JA - INTEGER, INTENT(IN) :: JB - INTEGER, INTENT(IN) :: NU - INTEGER, INTENT(IN) :: IA - INTEGER, INTENT(IN) :: IB - INTEGER, INTENT(IN) :: IC - INTEGER, INTENT(IN) :: ID - INTEGER, INTENT(IN) :: ITYPE - REAL(DOUBLE), INTENT(IN) :: COEF + SUBROUTINE talk (JA, JB, NU, IA, IB, IC, ID, ITYPE, COEF) + USE vast_kind_param,ONLY: DOUBLE + INTEGER, INTENT(IN) :: JA + INTEGER, INTENT(IN) :: JB + INTEGER, INTENT(IN) :: NU + INTEGER, INTENT(IN) :: IA + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(IN) :: IC + INTEGER, INTENT(IN) :: ID + INTEGER, INTENT(IN) :: ITYPE + REAL(DOUBLE), INTENT(IN) :: COEF !VAST.../BUFFER/ NBDIM(IN), NVCOEF(INOUT) !VAST.../DEBUG/ IBUG1(IN) !VAST.../ORB4/ NP(IN) !VAST.../ORB10/ NH(IN) !VAST...Calls: ALCBUF !...This routine performs I/O. - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/libmod/AME_C.f90 b/src/lib/libmod/AME_C.f90 index 7c694e4b2..ebcc6c291 100644 --- a/src/lib/libmod/AME_C.f90 +++ b/src/lib/libmod/AME_C.f90 @@ -1,8 +1,8 @@ - MODULE AME_C + MODULE AME_C USE vast_kind_param, ONLY: DOUBLE -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER :: INUMB_Int1, INUMB_Int2 INTEGER, DIMENSION(2000) :: Int1, Int2 REAL(DOUBLE), DIMENSION(2000) :: AInt1, AInt2 - END MODULE AME_C + END MODULE AME_C diff --git a/src/lib/libmod/Makefile b/src/lib/libmod/Makefile old mode 100755 new mode 100644 index 94ef6c7be..43ffe32e8 --- a/src/lib/libmod/Makefile +++ b/src/lib/libmod/Makefile @@ -31,7 +31,7 @@ MODOBJ = \ \ decide_C.o ncdist_C.o coeils_C.o bilst_C.o keilst_C.o vinlst_C.o vpilst_C.o stor_C.o bess_C.o \ bcore_C.o cteilsrk_C.o kkstart_C.o horb_C.o blim_C.o fposition_C.o sacoef_C.o \ - kkstartbreit_C.o # mpi_C.o delete for serial code only, delte mpi_C.i + kkstartbreit_C.o # mpi_C.o delete for serial code only, delte mpi_C.i install : $(LIBA) diff --git a/src/lib/libmod/bcore_C.f90 b/src/lib/libmod/bcore_C.f90 index d3adf0282..2fa6a46f9 100644 --- a/src/lib/libmod/bcore_C.f90 +++ b/src/lib/libmod/bcore_C.f90 @@ -1,8 +1,8 @@ - MODULE bcore_C + MODULE bcore_C ! Gediminas Gaigalas 10/05/17 - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer - INTEGER, DIMENSION(NNNW) :: ICORE - END MODULE bcore_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer + INTEGER, DIMENSION(NNNW) :: ICORE + END MODULE bcore_C diff --git a/src/lib/libmod/bess_C.f90 b/src/lib/libmod/bess_C.f90 index f0cbedc9c..3f8b47b1a 100644 --- a/src/lib/libmod/bess_C.f90 +++ b/src/lib/libmod/bess_C.f90 @@ -1,11 +1,11 @@ - MODULE bess_C - USE vast_kind_param, ONLY: DOUBLE + MODULE bess_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(2) :: WIJ - REAL(DOUBLE), DIMENSION(2,2,NNNP) :: BESSJ, BESSN - REAL(DOUBLE), DIMENSION(NNNP,3) :: BJ - REAL(DOUBLE), DIMENSION(NNNP) :: TC, TD - END MODULE bess_C + REAL(DOUBLE), DIMENSION(2) :: WIJ + REAL(DOUBLE), DIMENSION(2,2,NNNP) :: BESSJ, BESSN + REAL(DOUBLE), DIMENSION(NNNP,3) :: BJ + REAL(DOUBLE), DIMENSION(NNNP) :: TC, TD + END MODULE bess_C diff --git a/src/lib/libmod/bilst_C.f90 b/src/lib/libmod/bilst_C.f90 index 2dba9afab..ae831b61e 100644 --- a/src/lib/libmod/bilst_C.f90 +++ b/src/lib/libmod/bilst_C.f90 @@ -1,12 +1,12 @@ - MODULE bilst_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE bilst_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(6) :: NDTPA, NTPI + INTEGER, DIMENSION(6) :: NDTPA, NTPI INTEGER, DIMENSION(:), pointer :: indtp1, indtp2, indtp3, indtp4, & indtp5, indtp6 REAL(DOUBLE), DIMENSION(:), pointer :: valtp1, valtp2, valtp3, valtp4, & valtp5, valtp6 - LOGICAL, DIMENSION(6) :: FIRST - END MODULE bilst_C + LOGICAL, DIMENSION(6) :: FIRST + END MODULE bilst_C diff --git a/src/lib/libmod/biorb_C.f90 b/src/lib/libmod/biorb_C.f90 index d01e14512..4d021fe51 100644 --- a/src/lib/libmod/biorb_C.f90 +++ b/src/lib/libmod/biorb_C.f90 @@ -1,14 +1,14 @@ - MODULE biorb_C - USE vast_kind_param, ONLY:DOUBLE + MODULE biorb_C + USE vast_kind_param, ONLY:DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - CHARACTER, DIMENSION(NNNW) :: NHFF*2, NHII*2 + CHARACTER, DIMENSION(NNNW) :: NHFF*2, NHII*2 REAL(DOUBLE), DIMENSION(NNNW) :: EFF, GAMAFF , EII, GAMAII - INTEGER :: NCFFF, NWFF, NCFII, NWII - INTEGER, DIMENSION(NNNW) :: NPFF, NAKFF, NPII, NAKII - INTEGER, DIMENSION(NNNW) :: NKLFF, NKJFF, NKLII, NKJII - INTEGER, DIMENSION(NNNW) :: NNFF, NNII - END MODULE biorb_C + INTEGER :: NCFFF, NWFF, NCFII, NWII + INTEGER, DIMENSION(NNNW) :: NPFF, NAKFF, NPII, NAKII + INTEGER, DIMENSION(NNNW) :: NKLFF, NKJFF, NKLII, NKJII + INTEGER, DIMENSION(NNNW) :: NNFF, NNII + END MODULE biorb_C diff --git a/src/lib/libmod/blim_C.f90 b/src/lib/libmod/blim_C.f90 index 5cea46ce9..2e8ee7aca 100644 --- a/src/lib/libmod/blim_C.f90 +++ b/src/lib/libmod/blim_C.f90 @@ -1,8 +1,8 @@ - MODULE blim_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE blim_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: IPRERUN, NCSFPRE - REAL(DOUBLE) :: COEFFCUT1, COEFFCUT2 - END MODULE blim_C + INTEGER :: IPRERUN, NCSFPRE + REAL(DOUBLE) :: COEFFCUT1, COEFFCUT2 + END MODULE blim_C diff --git a/src/lib/libmod/blk_C.f90 b/src/lib/libmod/blk_C.f90 index f43739bd3..dce7ebb4b 100644 --- a/src/lib/libmod/blk_C.f90 +++ b/src/lib/libmod/blk_C.f90 @@ -1,19 +1,19 @@ ! !*********************************************************************** ! * - MODULE blk_C + MODULE blk_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(20) :: NCFBLK, NEVINBLK, NCFINBLK, TWO_J - INTEGER :: NBLOCK - REAL(DOUBLE), DIMENSION(:), pointer :: IDXBLK - INTEGER :: NELECTOT, NCFTOT, NWTOT, NVECTOT, NVECSIZTOT, NBLOCK1 - INTEGER :: NBLOCKI - INTEGER :: NBLOCKF - INTEGER, DIMENSION(10) :: NCFI - INTEGER, DIMENSION(10) :: NCFF - END MODULE blk_C + INTEGER :: NBLOCK + REAL(DOUBLE), DIMENSION(:), pointer :: IDXBLK + INTEGER :: NELECTOT, NCFTOT, NWTOT, NVECTOT, NVECSIZTOT, NBLOCK1 + INTEGER :: NBLOCKI + INTEGER :: NBLOCKF + INTEGER, DIMENSION(10) :: NCFI + INTEGER, DIMENSION(10) :: NCFF + END MODULE blk_C diff --git a/src/lib/libmod/blkidx_C.f90 b/src/lib/libmod/blkidx_C.f90 index ca5a4ca1c..42725e926 100644 --- a/src/lib/libmod/blkidx_C.f90 +++ b/src/lib/libmod/blkidx_C.f90 @@ -1,7 +1,7 @@ - MODULE blkidx_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE blkidx_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(:), POINTER :: IDXBLK - END MODULE blkidx_C + END MODULE blkidx_C diff --git a/src/lib/libmod/buffer_C.f90 b/src/lib/libmod/buffer_C.f90 index b609a4559..1e1926a9f 100644 --- a/src/lib/libmod/buffer_C.f90 +++ b/src/lib/libmod/buffer_C.f90 @@ -1,9 +1,9 @@ - MODULE buffer_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 13:03:28 1/25/07 -!...Modified by Charlotte Froese Fischer + MODULE buffer_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 13:03:28 1/25/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NBDIM, NVCOEF + INTEGER :: NBDIM, NVCOEF INTEGER, DIMENSION(:,:), pointer :: label REAL(DOUBLE), DIMENSION(:), pointer :: coeff - END MODULE buffer_C + END MODULE buffer_C diff --git a/src/lib/libmod/cffmat_C.f90 b/src/lib/libmod/cffmat_C.f90 index cfc78abba..356f21dd7 100644 --- a/src/lib/libmod/cffmat_C.f90 +++ b/src/lib/libmod/cffmat_C.f90 @@ -1,8 +1,8 @@ - MODULE cffmat_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE cffmat_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: NLMAX = 20 - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CFCI - END MODULE cffmat_C + INTEGER, PARAMETER :: NLMAX = 20 + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CFCI + END MODULE cffmat_C diff --git a/src/lib/libmod/ciimat_C.f90 b/src/lib/libmod/ciimat_C.f90 index c8abe55dc..77d10b260 100644 --- a/src/lib/libmod/ciimat_C.f90 +++ b/src/lib/libmod/ciimat_C.f90 @@ -1,8 +1,8 @@ - MODULE ciimat_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE ciimat_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: NLMAX = 20 - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CICI - END MODULE ciimat_C + INTEGER, PARAMETER :: NLMAX = 20 + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CICI + END MODULE ciimat_C diff --git a/src/lib/libmod/cimat_C.f90 b/src/lib/libmod/cimat_C.f90 index fa89db8c2..87cde14db 100644 --- a/src/lib/libmod/cimat_C.f90 +++ b/src/lib/libmod/cimat_C.f90 @@ -1,9 +1,9 @@ - MODULE cimat_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE cimat_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: NLMAX = 20 - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CFCI - REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CICI - END MODULE cimat_C + INTEGER, PARAMETER :: NLMAX = 20 + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CFCI + REAL(DOUBLE), DIMENSION(20*NLMAX*NLMAX) :: CICI + END MODULE cimat_C diff --git a/src/lib/libmod/cnc_C.f90 b/src/lib/libmod/cnc_C.f90 index 9d608de28..402d5451c 100644 --- a/src/lib/libmod/cnc_C.f90 +++ b/src/lib/libmod/cnc_C.f90 @@ -1,8 +1,8 @@ - MODULE cnc_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE cnc_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(2:5,2:4) :: CNC5C - REAL(DOUBLE), DIMENSION(6,2:6) :: CNC6C - END MODULE cnc_C + REAL(DOUBLE), DIMENSION(2:5,2:4) :: CNC5C + REAL(DOUBLE), DIMENSION(6,2:6) :: CNC6C + END MODULE cnc_C diff --git a/src/lib/libmod/coeils_C.f90 b/src/lib/libmod/coeils_C.f90 index 6677f4a8e..788140466 100644 --- a/src/lib/libmod/coeils_C.f90 +++ b/src/lib/libmod/coeils_C.f90 @@ -1,10 +1,10 @@ - MODULE coeils_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE coeils_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NDCOEA, NCOEI + INTEGER :: NDCOEA, NCOEI INTEGER, DIMENSION(:), pointer :: indoei REAL(DOUBLE), DIMENSION(:), pointer :: valoei - LOGICAL :: FRSTCO - END MODULE coeils_C + LOGICAL :: FRSTCO + END MODULE coeils_C diff --git a/src/lib/libmod/cons_C.f90 b/src/lib/libmod/cons_C.f90 index 61c5cf20f..e07235e38 100644 --- a/src/lib/libmod/cons_C.f90 +++ b/src/lib/libmod/cons_C.f90 @@ -1,12 +1,12 @@ ! !*********************************************************************** ! * - MODULE cons_C + MODULE cons_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 10:42:40 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE) :: ZERO = 0.0D00, & HALF = 0.5D00, & @@ -19,4 +19,4 @@ MODULE cons_C TEN =10.0D00, & ELEVEN=11.0D00, & EPS = 1.0D-08 - END MODULE cons_C + END MODULE cons_C diff --git a/src/lib/libmod/core_C.f90 b/src/lib/libmod/core_C.f90 index d5ab4b1e4..7bee99b57 100644 --- a/src/lib/libmod/core_C.f90 +++ b/src/lib/libmod/core_C.f90 @@ -1,6 +1,6 @@ - MODULE core_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE core_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NCORE - END MODULE core_C + INTEGER :: NCORE + END MODULE core_C diff --git a/src/lib/libmod/corre_C.f90 b/src/lib/libmod/corre_C.f90 index c9e327048..794c99046 100644 --- a/src/lib/libmod/corre_C.f90 +++ b/src/lib/libmod/corre_C.f90 @@ -1,8 +1,8 @@ - MODULE corre_C - USE vast_kind_param, ONLY: DOUBLE + MODULE corre_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 15:25:01 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL, DIMENSION(NNNW) :: LCORRE - END MODULE corre_C + LOGICAL, DIMENSION(NNNW) :: LCORRE + END MODULE corre_C diff --git a/src/lib/libmod/coun_C.f90 b/src/lib/libmod/coun_C.f90 index b19004c8e..e518a95c1 100644 --- a/src/lib/libmod/coun_C.f90 +++ b/src/lib/libmod/coun_C.f90 @@ -1,7 +1,7 @@ - MODULE coun_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer + MODULE coun_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE) :: THRESH - END MODULE coun_C + REAL(DOUBLE) :: THRESH + END MODULE coun_C diff --git a/src/lib/libmod/couple_C.f90 b/src/lib/libmod/couple_C.f90 index 5a97f4e68..0512934ea 100644 --- a/src/lib/libmod/couple_C.f90 +++ b/src/lib/libmod/couple_C.f90 @@ -1,12 +1,12 @@ - MODULE couple_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE couple_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: MANGM = 60 - INTEGER, PARAMETER :: MTRIAD = 12 - INTEGER, DIMENSION(MANGM) :: J1 - INTEGER, DIMENSION(MTRIAD,3) :: J2, J3 - INTEGER :: MJA, NJA - LOGICAL, DIMENSION(MANGM) :: FREE - END MODULE couple_C + INTEGER, PARAMETER :: MANGM = 60 + INTEGER, PARAMETER :: MTRIAD = 12 + INTEGER, DIMENSION(MANGM) :: J1 + INTEGER, DIMENSION(MTRIAD,3) :: J2, J3 + INTEGER :: MJA, NJA + LOGICAL, DIMENSION(MANGM) :: FREE + END MODULE couple_C diff --git a/src/lib/libmod/cteilsrk_C.f90 b/src/lib/libmod/cteilsrk_C.f90 index c86b56341..517ff6683 100644 --- a/src/lib/libmod/cteilsrk_C.f90 +++ b/src/lib/libmod/cteilsrk_C.f90 @@ -1,8 +1,8 @@ - MODULE cteilsrk_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE cteilsrk_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(:), pointer :: indteirk REAL(DOUBLE), DIMENSION(:), pointer :: valteirk - END MODULE cteilsrk_C + END MODULE cteilsrk_C diff --git a/src/lib/libmod/cuto_C.f90 b/src/lib/libmod/cuto_C.f90 index 1fa90cccf..bec7ade21 100644 --- a/src/lib/libmod/cuto_C.f90 +++ b/src/lib/libmod/cuto_C.f90 @@ -1,7 +1,7 @@ - MODULE cuto_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE cuto_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 07:39:37 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE) :: CUTOFF - END MODULE cuto_C + REAL(DOUBLE) :: CUTOFF + END MODULE cuto_C diff --git a/src/lib/libmod/damp_C.f90 b/src/lib/libmod/damp_C.f90 index 994f2c621..605590766 100644 --- a/src/lib/libmod/damp_C.f90 +++ b/src/lib/libmod/damp_C.f90 @@ -1,11 +1,11 @@ - MODULE damp_C + MODULE damp_C ! Arrays associated with damping solutions in the SCF process ! ... ODAMP: array for damping radial functions ! ... CDAMP: array for damping expansion coefficients -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW - REAL(DOUBLE), DIMENSION(NNNW) :: ODAMP + REAL(DOUBLE), DIMENSION(NNNW) :: ODAMP REAL(DOUBLE), DIMENSION(:), pointer :: cdamp - END MODULE damp_C + END MODULE damp_C diff --git a/src/lib/libmod/debug_C.f90 b/src/lib/libmod/debug_C.f90 index 99fb3aff6..d83ee7092 100644 --- a/src/lib/libmod/debug_C.f90 +++ b/src/lib/libmod/debug_C.f90 @@ -1,16 +1,16 @@ ! !*********************************************************************** ! * - MODULE debug_C + MODULE debug_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6 - LOGICAL, DIMENSION(5) :: LDBPA - LOGICAL, DIMENSION(5) :: LDBPG - LOGICAL, DIMENSION(30) :: LDBPR + INTEGER :: IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6 + LOGICAL, DIMENSION(5) :: LDBPA + LOGICAL, DIMENSION(5) :: LDBPG + LOGICAL, DIMENSION(30) :: LDBPR REAL(DOUBLE) :: cutoff ! used by bioscl - END MODULE debug_C + END MODULE debug_C diff --git a/src/lib/libmod/decide_C.f90 b/src/lib/libmod/decide_C.f90 index 22711b6c9..5562a55ef 100644 --- a/src/lib/libmod/decide_C.f90 +++ b/src/lib/libmod/decide_C.f90 @@ -1,7 +1,7 @@ - MODULE decide_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE decide_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL :: LFORDR, LTRANS, LVP, LSE, LNMS, LSMS - END MODULE decide_C + LOGICAL :: LFORDR, LTRANS, LVP, LSE, LNMS, LSMS + END MODULE decide_C diff --git a/src/lib/libmod/def_C.f90 b/src/lib/libmod/def_C.f90 index 44a01810e..430badc94 100644 --- a/src/lib/libmod/def_C.f90 +++ b/src/lib/libmod/def_C.f90 @@ -1,31 +1,31 @@ ! !*********************************************************************** ! * - MODULE def_C + MODULE def_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE) :: TENMAX, EXPMAX, EXPMIN, PRECIS - REAL(DOUBLE) :: AUCM, AUEV, CCMS, FASI, FBSI + REAL(DOUBLE) :: TENMAX, EXPMAX, EXPMIN, PRECIS + REAL(DOUBLE) :: AUCM, AUEV, CCMS, FASI, FBSI REAL(DOUBLE) :: FMTOAU, AUMAMU, B1 - INTEGER :: IONCTY, NELEC - REAL(DOUBLE) :: EMN, Z - INTEGER :: IONCTYFF, NELECFF - REAL(DOUBLE) :: EMNFF, ZFF - INTEGER :: IONCTYII, NELECII - REAL(DOUBLE) :: EMNII, ZII - INTEGER :: NELECR - REAL(DOUBLE) :: C - REAL(DOUBLE) :: EMPAM, RBCM - INTEGER :: NSCF, NSIC, NSOLV - REAL(DOUBLE) :: ACCY + INTEGER :: IONCTY, NELEC + REAL(DOUBLE) :: EMN, Z + INTEGER :: IONCTYFF, NELECFF + REAL(DOUBLE) :: EMNFF, ZFF + INTEGER :: IONCTYII, NELECII + REAL(DOUBLE) :: EMNII, ZII + INTEGER :: NELECR + REAL(DOUBLE) :: C + REAL(DOUBLE) :: EMPAM, RBCM + INTEGER :: NSCF, NSIC, NSOLV + REAL(DOUBLE) :: ACCY REAL(DOUBLE), DIMENSION(:), pointer :: wt, weight - INTEGER :: NCMIN, NCMAX + INTEGER :: NCMIN, NCMAX INTEGER, DIMENSION(:), pointer :: iccmin - REAL(DOUBLE) :: CVAC, PI - REAL(DOUBLE), DIMENSION(NNNP) :: DP, DQ - END MODULE def_C + REAL(DOUBLE) :: CVAC, PI + REAL(DOUBLE), DIMENSION(NNNP) :: DP, DQ + END MODULE def_C diff --git a/src/lib/libmod/default_C.f90 b/src/lib/libmod/default_C.f90 index fdaa11243..7a3f2bd6d 100644 --- a/src/lib/libmod/default_C.f90 +++ b/src/lib/libmod/default_C.f90 @@ -1,7 +1,7 @@ - MODULE default_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE default_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NDEF, NDUMP, INPCI - END MODULE default_C + INTEGER :: NDEF, NDUMP, INPCI + END MODULE default_C diff --git a/src/lib/libmod/dumx_C.f90 b/src/lib/libmod/dumx_C.f90 index 03c857ec4..2e78c2809 100644 --- a/src/lib/libmod/dumx_C.f90 +++ b/src/lib/libmod/dumx_C.f90 @@ -1,8 +1,8 @@ - MODULE dumx_C + MODULE dumx_C use cons_C -!...Created by Pacific-Sierra Research 77to90 4.3E 10:50:24 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 10:50:24 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 USE parameter_def, ONLY: NNNW - INTEGER, DIMENSION(NNNW) :: JLIS, JC1S, JC2S - END MODULE dumx_C + INTEGER, DIMENSION(NNNW) :: JLIS, JC1S, JC2S + END MODULE dumx_C diff --git a/src/lib/libmod/eigv_C.f90 b/src/lib/libmod/eigv_C.f90 index 5cf25f374..0ccec1af5 100644 --- a/src/lib/libmod/eigv_C.f90 +++ b/src/lib/libmod/eigv_C.f90 @@ -1,14 +1,14 @@ ! !*********************************************************************** ! * - MODULE eigv_C + MODULE eigv_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE) :: EAV, EAVFF, EAVII REAL(DOUBLE), DIMENSION(:), pointer :: EVAL, EVALFF, EVALII REAL(DOUBLE), DIMENSION(:), pointer :: EVEC, EVECFF, EVECII - END MODULE eigv_C + END MODULE eigv_C diff --git a/src/lib/libmod/eigvec1_C.f90 b/src/lib/libmod/eigvec1_C.f90 index a1f127a09..9fae92bdd 100644 --- a/src/lib/libmod/eigvec1_C.f90 +++ b/src/lib/libmod/eigvec1_C.f90 @@ -1,7 +1,7 @@ - MODULE eigvec1_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE eigvec1_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE), DIMENSION(:), pointer :: evec1 - END MODULE eigvec1_C + END MODULE eigvec1_C diff --git a/src/lib/libmod/facts_C.f90 b/src/lib/libmod/facts_C.f90 index 909ac7945..c90840bee 100644 --- a/src/lib/libmod/facts_C.f90 +++ b/src/lib/libmod/facts_C.f90 @@ -1,13 +1,13 @@ ! !*********************************************************************** ! * - MODULE facts_C + MODULE facts_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 10:46:52 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: MFACT = 500 - REAL(DOUBLE), DIMENSION(MFACT) :: GAM - END MODULE facts_C + INTEGER, PARAMETER :: MFACT = 500 + REAL(DOUBLE), DIMENSION(MFACT) :: GAM + END MODULE facts_C diff --git a/src/lib/libmod/fixd_C.f90 b/src/lib/libmod/fixd_C.f90 index 326b6c206..b700faddf 100644 --- a/src/lib/libmod/fixd_C.f90 +++ b/src/lib/libmod/fixd_C.f90 @@ -1,9 +1,9 @@ - MODULE fixd_C - USE vast_kind_param, ONLY: DOUBLE + MODULE fixd_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NFIX - LOGICAL, DIMENSION(NNNW) :: LFIX - END MODULE fixd_C + INTEGER :: NFIX + LOGICAL, DIMENSION(NNNW) :: LFIX + END MODULE fixd_C diff --git a/src/lib/libmod/foparm_C.f90 b/src/lib/libmod/foparm_C.f90 index c1b5a5446..7aa5a9fd1 100644 --- a/src/lib/libmod/foparm_C.f90 +++ b/src/lib/libmod/foparm_C.f90 @@ -1,7 +1,7 @@ - MODULE foparm_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE foparm_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 -! INTEGER, DIMENSION(100) :: ICCUT - INTEGER :: ICCUT - END MODULE foparm_C +! INTEGER, DIMENSION(100) :: ICCUT + INTEGER :: ICCUT + END MODULE foparm_C diff --git a/src/lib/libmod/fposition_C.f90 b/src/lib/libmod/fposition_C.f90 index 35ebe2af6..47d6c0c1d 100644 --- a/src/lib/libmod/fposition_C.f90 +++ b/src/lib/libmod/fposition_C.f90 @@ -1,6 +1,6 @@ - MODULE fposition_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE fposition_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NPOSITION - END MODULE fposition_C + INTEGER :: NPOSITION + END MODULE fposition_C diff --git a/src/lib/libmod/grid_C.f90 b/src/lib/libmod/grid_C.f90 index bb89c9d81..2e636a7be 100644 --- a/src/lib/libmod/grid_C.f90 +++ b/src/lib/libmod/grid_C.f90 @@ -1,10 +1,10 @@ - MODULE grid_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE grid_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:22:09 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 USE parameter_def, ONLY: NNN1 - INTEGER :: N - REAL(DOUBLE), DIMENSION(NNN1) :: R, RP, RPOR - REAL(DOUBLE) :: RNT, H, HP + INTEGER :: N + REAL(DOUBLE), DIMENSION(NNN1) :: R, RP, RPOR + REAL(DOUBLE) :: RNT, H, HP END MODULE grid_C diff --git a/src/lib/libmod/hblock_C.f90 b/src/lib/libmod/hblock_C.f90 index 31ec71390..9d1a54ead 100644 --- a/src/lib/libmod/hblock_C.f90 +++ b/src/lib/libmod/hblock_C.f90 @@ -1,11 +1,11 @@ - MODULE hblock_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:29:39 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE hblock_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:29:39 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER :: NBLOCK !! NCFBLK as an integer needs to be renamed -! REAL(DOUBLE) :: PNCFBLK -! REAL(DOUBLE) :: PNEVBLK, PNCMAXBLK +! REAL(DOUBLE) :: PNCFBLK +! REAL(DOUBLE) :: PNEVBLK, PNCMAXBLK INTEGER, DIMENSION(:), pointer :: ncfblk !! this is a problem INTEGER, DIMENSION(:), pointer :: nevblk, ncmaxblk - END MODULE hblock_C + END MODULE hblock_C diff --git a/src/lib/libmod/hmat_C.f90 b/src/lib/libmod/hmat_C.f90 index 60567d648..c68c39c13 100644 --- a/src/lib/libmod/hmat_C.f90 +++ b/src/lib/libmod/hmat_C.f90 @@ -1,15 +1,15 @@ - MODULE hmat_C + MODULE hmat_C USE vast_kind_param, ONLY: DOUBLE, LONG -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER(LONG) :: NELMNT + INTEGER(LONG) :: NELMNT REAL(DOUBLE), DIMENSION(:), pointer :: emt - INTEGER, DIMENSION(:), pointer :: iendc + INTEGER, DIMENSION(:), pointer :: iendc INTEGER, DIMENSION(:), pointer :: irow - INTEGER, DIMENSION(6) :: NTPITMP + INTEGER, DIMENSION(6) :: NTPITMP INTEGER(LONG) :: NELMNTTMP INTEGER :: NCOEITMP, NCOECTMP, NCTEITMP, NCTECTMP, NMCBPTMP, & - NCORETMP, NVPITMP, NKEITMP, NVINTITMP, NCFTMP - REAL(DOUBLE) :: CUTOFFTMP - END MODULE hmat_C + NCORETMP, NVPITMP, NKEITMP, NVINTITMP, NCFTMP + REAL(DOUBLE) :: CUTOFFTMP + END MODULE hmat_C diff --git a/src/lib/libmod/horb_C.f90 b/src/lib/libmod/horb_C.f90 index 4afbb14ba..60a2abd44 100644 --- a/src/lib/libmod/horb_C.f90 +++ b/src/lib/libmod/horb_C.f90 @@ -1,8 +1,8 @@ - MODULE horb_C + MODULE horb_C USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH - END MODULE horb_C + REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH + END MODULE horb_C diff --git a/src/lib/libmod/hydpar_C.f90 b/src/lib/libmod/hydpar_C.f90 index 6e2936a95..18e17a962 100644 --- a/src/lib/libmod/hydpar_C.f90 +++ b/src/lib/libmod/hydpar_C.f90 @@ -1,8 +1,8 @@ - MODULE hydpar_C - USE vast_kind_param, ONLY: DOUBLE + MODULE hydpar_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 - REAL(DOUBLE), DIMENSION(NNNW) :: SIGMA - END MODULE hydpar_C +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 + REAL(DOUBLE), DIMENSION(NNNW) :: SIGMA + END MODULE hydpar_C diff --git a/src/lib/libmod/iccu_C.f90 b/src/lib/libmod/iccu_C.f90 index a841236d3..6ad9bf4ae 100644 --- a/src/lib/libmod/iccu_C.f90 +++ b/src/lib/libmod/iccu_C.f90 @@ -1,6 +1,6 @@ - MODULE iccu_C -!...Modified by Charlotte Froese Fischer + MODULE iccu_C +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(100) :: ICCUT INTEGER, DIMENSION(:), pointer :: iccutblk - END MODULE iccu_C + END MODULE iccu_C diff --git a/src/lib/libmod/int_C.f90 b/src/lib/libmod/int_C.f90 index ca35c1ba4..570bc72c1 100644 --- a/src/lib/libmod/int_C.f90 +++ b/src/lib/libmod/int_C.f90 @@ -1,11 +1,11 @@ - MODULE int_C - USE vast_kind_param, ONLY: DOUBLE + MODULE int_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: MTP0 - REAL(DOUBLE), DIMENSION(NNNP) :: P, Q - REAL(DOUBLE) :: P0, Q0 - REAL(DOUBLE), DIMENSION(NNNP) :: TF, TG, XU, XV - END MODULE int_C + INTEGER :: MTP0 + REAL(DOUBLE), DIMENSION(NNNP) :: P, Q + REAL(DOUBLE) :: P0, Q0 + REAL(DOUBLE), DIMENSION(NNNP) :: TF, TG, XU, XV + END MODULE int_C diff --git a/src/lib/libmod/invt_C.f90 b/src/lib/libmod/invt_C.f90 index 95fc045b0..074663d84 100644 --- a/src/lib/libmod/invt_C.f90 +++ b/src/lib/libmod/invt_C.f90 @@ -1,8 +1,8 @@ - MODULE invt_C - USE vast_kind_param, ONLY: DOUBLE + MODULE invt_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL, DIMENSION(NNNW) :: NOINVT - END MODULE invt_C + LOGICAL, DIMENSION(NNNW) :: NOINVT + END MODULE invt_C diff --git a/src/lib/libmod/iounit_C.f90 b/src/lib/libmod/iounit_C.f90 index b4abe6e8c..fc6097241 100644 --- a/src/lib/libmod/iounit_C.f90 +++ b/src/lib/libmod/iounit_C.f90 @@ -1,11 +1,11 @@ ! !*********************************************************************** ! * - MODULE iounit_C + MODULE iounit_C ! * !*********************************************************************** -!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: ISTDI=5, ISTDO=6, ISTDE=0 - END MODULE iounit_C + INTEGER :: ISTDI=5, ISTDO=6, ISTDE=0 + END MODULE iounit_C diff --git a/src/lib/libmod/jj2lsj_C.f90 b/src/lib/libmod/jj2lsj_C.f90 index 47c0e4d79..a3591a732 100644 --- a/src/lib/libmod/jj2lsj_C.f90 +++ b/src/lib/libmod/jj2lsj_C.f90 @@ -1,7 +1,7 @@ ! !*********************************************************************** ! * - MODULE jj2lsj_C + MODULE jj2lsj_C ! * ! This module contains the (numerical) values of the subshell * ! terms in LS-coupling and in it are define some global variables * @@ -11,7 +11,7 @@ MODULE jj2lsj_C ! NIST last update: May 2011 * ! * !*********************************************************************** - USE vast_kind_param, ONLY: LONG, DOUBLE + USE vast_kind_param, ONLY: LONG, DOUBLE ! ! Define some global data for the jj2LSJ transformation program ! @@ -349,99 +349,99 @@ MODULE jj2lsj_C subshell_term_LS(5, 0,10,10, 1) /) type(subshell_term_LS), dimension(1:11), parameter :: & term_LS_h2 =(/ & - subshell_term_LS(5, 0,11, 0, 0), & - subshell_term_LS(5, 0, 9, 2, 2), & - subshell_term_LS(5, 0, 9, 4, 0), & - subshell_term_LS(5, 0, 9, 6, 2), & - subshell_term_LS(5, 0, 9, 8, 0), & - subshell_term_LS(5, 0, 9,10, 2), & - subshell_term_LS(5, 0, 9,12, 0), & - subshell_term_LS(5, 0, 9,14, 2), & - subshell_term_LS(5, 0, 9,16, 0), & - subshell_term_LS(5, 0, 9,18, 2), & + subshell_term_LS(5, 0,11, 0, 0), & + subshell_term_LS(5, 0, 9, 2, 2), & + subshell_term_LS(5, 0, 9, 4, 0), & + subshell_term_LS(5, 0, 9, 6, 2), & + subshell_term_LS(5, 0, 9, 8, 0), & + subshell_term_LS(5, 0, 9,10, 2), & + subshell_term_LS(5, 0, 9,12, 0), & + subshell_term_LS(5, 0, 9,14, 2), & + subshell_term_LS(5, 0, 9,16, 0), & + subshell_term_LS(5, 0, 9,18, 2), & subshell_term_LS(5, 0, 9,20, 0) /) type(subshell_term_LS), dimension(1:1), parameter :: & term_LS_i1 =(/ & subshell_term_LS(6, 0,12,12, 1) /) type(subshell_term_LS), dimension(1:13), parameter :: & term_LS_i2 =(/ & - subshell_term_LS(6, 0,13, 0, 0), & - subshell_term_LS(6, 0,11, 2, 2), & - subshell_term_LS(6, 0,11, 4, 0), & - subshell_term_LS(6, 0,11, 6, 2), & - subshell_term_LS(6, 0,11, 8, 0), & - subshell_term_LS(6, 0,11,10, 2), & - subshell_term_LS(6, 0,11,12, 0), & - subshell_term_LS(6, 0,11,14, 2), & - subshell_term_LS(6, 0,11,16, 0), & - subshell_term_LS(6, 0,11,18, 2), & - subshell_term_LS(6, 0,11,20, 0), & - subshell_term_LS(6, 0,11,22, 2), & + subshell_term_LS(6, 0,13, 0, 0), & + subshell_term_LS(6, 0,11, 2, 2), & + subshell_term_LS(6, 0,11, 4, 0), & + subshell_term_LS(6, 0,11, 6, 2), & + subshell_term_LS(6, 0,11, 8, 0), & + subshell_term_LS(6, 0,11,10, 2), & + subshell_term_LS(6, 0,11,12, 0), & + subshell_term_LS(6, 0,11,14, 2), & + subshell_term_LS(6, 0,11,16, 0), & + subshell_term_LS(6, 0,11,18, 2), & + subshell_term_LS(6, 0,11,20, 0), & + subshell_term_LS(6, 0,11,22, 2), & subshell_term_LS(6, 0,11,24, 0) /) type(subshell_term_LS), dimension(1:1), parameter :: & term_LS_k1 =(/ & subshell_term_LS(7, 0,14,14, 1) /) type(subshell_term_LS), dimension(1:15), parameter :: & term_LS_k2 =(/ & - subshell_term_LS(7, 0,15, 0, 0), & - subshell_term_LS(7, 0,13, 2, 2), & - subshell_term_LS(7, 0,13, 4, 0), & - subshell_term_LS(7, 0,13, 6, 2), & - subshell_term_LS(7, 0,13, 8, 0), & - subshell_term_LS(7, 0,13,10, 2), & - subshell_term_LS(7, 0,13,12, 0), & - subshell_term_LS(7, 0,13,14, 2), & - subshell_term_LS(7, 0,13,16, 0), & - subshell_term_LS(7, 0,13,18, 2), & - subshell_term_LS(7, 0,13,20, 0), & - subshell_term_LS(7, 0,13,22, 2), & - subshell_term_LS(7, 0,13,24, 0), & - subshell_term_LS(7, 0,13,26, 2), & + subshell_term_LS(7, 0,15, 0, 0), & + subshell_term_LS(7, 0,13, 2, 2), & + subshell_term_LS(7, 0,13, 4, 0), & + subshell_term_LS(7, 0,13, 6, 2), & + subshell_term_LS(7, 0,13, 8, 0), & + subshell_term_LS(7, 0,13,10, 2), & + subshell_term_LS(7, 0,13,12, 0), & + subshell_term_LS(7, 0,13,14, 2), & + subshell_term_LS(7, 0,13,16, 0), & + subshell_term_LS(7, 0,13,18, 2), & + subshell_term_LS(7, 0,13,20, 0), & + subshell_term_LS(7, 0,13,22, 2), & + subshell_term_LS(7, 0,13,24, 0), & + subshell_term_LS(7, 0,13,26, 2), & subshell_term_LS(7, 0,13,28, 0) /) type(subshell_term_LS), dimension(1:1), parameter :: & term_LS_l1 =(/ & subshell_term_LS(8, 0,16,16, 1) /) type(subshell_term_LS), dimension(1:17), parameter :: & term_LS_l2 =(/ & - subshell_term_LS(8, 0,17, 0, 0), & - subshell_term_LS(8, 0,15, 2, 2), & - subshell_term_LS(8, 0,15, 4, 0), & - subshell_term_LS(8, 0,15, 6, 2), & - subshell_term_LS(8, 0,15, 8, 0), & - subshell_term_LS(8, 0,15,10, 2), & - subshell_term_LS(8, 0,15,12, 0), & - subshell_term_LS(8, 0,15,14, 2), & - subshell_term_LS(8, 0,15,16, 0), & - subshell_term_LS(8, 0,15,18, 2), & - subshell_term_LS(8, 0,15,20, 0), & - subshell_term_LS(8, 0,15,22, 2), & - subshell_term_LS(8, 0,15,24, 0), & - subshell_term_LS(8, 0,15,26, 2), & - subshell_term_LS(8, 0,15,28, 0), & - subshell_term_LS(8, 0,15,30, 2), & + subshell_term_LS(8, 0,17, 0, 0), & + subshell_term_LS(8, 0,15, 2, 2), & + subshell_term_LS(8, 0,15, 4, 0), & + subshell_term_LS(8, 0,15, 6, 2), & + subshell_term_LS(8, 0,15, 8, 0), & + subshell_term_LS(8, 0,15,10, 2), & + subshell_term_LS(8, 0,15,12, 0), & + subshell_term_LS(8, 0,15,14, 2), & + subshell_term_LS(8, 0,15,16, 0), & + subshell_term_LS(8, 0,15,18, 2), & + subshell_term_LS(8, 0,15,20, 0), & + subshell_term_LS(8, 0,15,22, 2), & + subshell_term_LS(8, 0,15,24, 0), & + subshell_term_LS(8, 0,15,26, 2), & + subshell_term_LS(8, 0,15,28, 0), & + subshell_term_LS(8, 0,15,30, 2), & subshell_term_LS(8, 0,15,32, 0) /) type(subshell_term_LS), dimension(1:1), parameter :: & term_LS_m1 =(/ & subshell_term_LS(9, 0,18,18, 1) /) type(subshell_term_LS), dimension(1:19), parameter :: & term_LS_m2 =(/ & - subshell_term_LS(9, 0,19, 0, 0), & - subshell_term_LS(9, 0,17, 2, 2), & - subshell_term_LS(9, 0,17, 4, 0), & - subshell_term_LS(9, 0,17, 6, 2), & - subshell_term_LS(9, 0,17, 8, 0), & - subshell_term_LS(9, 0,17,10, 2), & - subshell_term_LS(9, 0,17,12, 0), & - subshell_term_LS(9, 0,17,14, 2), & - subshell_term_LS(9, 0,17,16, 0), & - subshell_term_LS(9, 0,17,18, 2), & - subshell_term_LS(9, 0,17,20, 0), & - subshell_term_LS(9, 0,17,22, 2), & - subshell_term_LS(9, 0,17,24, 0), & - subshell_term_LS(9, 0,17,26, 2), & - subshell_term_LS(9, 0,17,28, 0), & - subshell_term_LS(9, 0,17,30, 2), & - subshell_term_LS(9, 0,17,32, 0), & - subshell_term_LS(9, 0,17,34, 2), & + subshell_term_LS(9, 0,19, 0, 0), & + subshell_term_LS(9, 0,17, 2, 2), & + subshell_term_LS(9, 0,17, 4, 0), & + subshell_term_LS(9, 0,17, 6, 2), & + subshell_term_LS(9, 0,17, 8, 0), & + subshell_term_LS(9, 0,17,10, 2), & + subshell_term_LS(9, 0,17,12, 0), & + subshell_term_LS(9, 0,17,14, 2), & + subshell_term_LS(9, 0,17,16, 0), & + subshell_term_LS(9, 0,17,18, 2), & + subshell_term_LS(9, 0,17,20, 0), & + subshell_term_LS(9, 0,17,22, 2), & + subshell_term_LS(9, 0,17,24, 0), & + subshell_term_LS(9, 0,17,26, 2), & + subshell_term_LS(9, 0,17,28, 0), & + subshell_term_LS(9, 0,17,30, 2), & + subshell_term_LS(9, 0,17,32, 0), & + subshell_term_LS(9, 0,17,34, 2), & subshell_term_LS(9, 0,17,36, 0) /) - END MODULE jj2lsj_C + END MODULE jj2lsj_C diff --git a/src/lib/libmod/jj2lsjbio_C.f90 b/src/lib/libmod/jj2lsjbio_C.f90 index 39a146e80..51ebc6e65 100644 --- a/src/lib/libmod/jj2lsjbio_C.f90 +++ b/src/lib/libmod/jj2lsjbio_C.f90 @@ -1,14 +1,14 @@ ! !*********************************************************************** ! * - MODULE jj2lsjbio_C + MODULE jj2lsjbio_C ! * ! * ! Written by G. Gaigalas, * ! NIST last update: May 2017 * ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! REAL(DOUBLE), DIMENSION(:), pointer :: RLev_ENER_1,RLev_ENER_2 CHARACTER(LEN=64), POINTER, DIMENSION(:) :: string_CSF1 diff --git a/src/lib/libmod/jlabl_C.f90 b/src/lib/libmod/jlabl_C.f90 index 7b3ba38df..8cb73e44e 100644 --- a/src/lib/libmod/jlabl_C.f90 +++ b/src/lib/libmod/jlabl_C.f90 @@ -1,9 +1,9 @@ - MODULE jlabl_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:16:25 2/14/04 -!...Modified by Charlotte Froese Fischer + MODULE jlabl_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:16:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - CHARACTER(LEN=4), DIMENSION(32) :: JLBL, JLBR - CHARACTER(LEN=4), DIMENSION(2) :: JLBP + CHARACTER(LEN=4), DIMENSION(32) :: JLBL, JLBR + CHARACTER(LEN=4), DIMENSION(2) :: JLBP ! ! Left-justified strings ! @@ -24,4 +24,4 @@ MODULE jlabl_C DATA JLBP/ ' - ', ' + '/ ! - END MODULE jlabl_C + END MODULE jlabl_C diff --git a/src/lib/libmod/jqjc_C.f90 b/src/lib/libmod/jqjc_C.f90 index d276d28d6..3de3fa8a8 100644 --- a/src/lib/libmod/jqjc_C.f90 +++ b/src/lib/libmod/jqjc_C.f90 @@ -1,7 +1,7 @@ - MODULE jqjc_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE jqjc_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(40) :: ITJQJ1, ITJQJ2 - INTEGER :: JQJ1, JQJ2, NTRANS - END MODULE jqjc_C + INTEGER, DIMENSION(40) :: ITJQJ1, ITJQJ2 + INTEGER :: JQJ1, JQJ2, NTRANS + END MODULE jqjc_C diff --git a/src/lib/libmod/keilst_C.f90 b/src/lib/libmod/keilst_C.f90 index e45c4af3d..ce6fd1e5d 100644 --- a/src/lib/libmod/keilst_C.f90 +++ b/src/lib/libmod/keilst_C.f90 @@ -1,10 +1,10 @@ - MODULE keilst_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE keilst_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NDKEA, NKEI + INTEGER :: NDKEA, NKEI INTEGER, DIMENSION(:), pointer :: indkei REAL(DOUBLE), DIMENSION(:), pointer :: valkei - LOGICAL :: FRSTKI - END MODULE keilst_C + LOGICAL :: FRSTKI + END MODULE keilst_C diff --git a/src/lib/libmod/kkstart_C.f90 b/src/lib/libmod/kkstart_C.f90 index 20ac29ebc..9184822fb 100644 --- a/src/lib/libmod/kkstart_C.f90 +++ b/src/lib/libmod/kkstart_C.f90 @@ -1,8 +1,8 @@ - MODULE kkstart_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE kkstart_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: KMAX = 20 - INTEGER, DIMENSION(0:KMAX) :: KSTART - END MODULE kkstart_C + INTEGER, PARAMETER :: KMAX = 20 + INTEGER, DIMENSION(0:KMAX) :: KSTART + END MODULE kkstart_C diff --git a/src/lib/libmod/kkstartbreit_C.f90 b/src/lib/libmod/kkstartbreit_C.f90 index fbd89df68..55720124c 100644 --- a/src/lib/libmod/kkstartbreit_C.f90 +++ b/src/lib/libmod/kkstartbreit_C.f90 @@ -4,8 +4,8 @@ MODULE kkstartbreit_C ! * !*********************************************************************** -!...Translated by Charlotte Froese Fischer +!...Translated by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, PARAMETER :: KMAX = 20 INTEGER, DIMENSION(0:KMAX) :: KSTARTBREIT1,KSTARTBREIT2 - END MODULE kkstartbreit_C + END MODULE kkstartbreit_C diff --git a/src/lib/libmod/l1_C.f90 b/src/lib/libmod/l1_C.f90 index d0c531784..883f144ea 100644 --- a/src/lib/libmod/l1_C.f90 +++ b/src/lib/libmod/l1_C.f90 @@ -1,9 +1,9 @@ - MODULE l1_C - USE vast_kind_param, ONLY: DOUBLE + MODULE l1_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(3,NNNW) :: JBQ1, JBQ2 - INTEGER, DIMENSION(3) :: JTQ1, JTQ2 - END MODULE l1_C + INTEGER, DIMENSION(3,NNNW) :: JBQ1, JBQ2 + INTEGER, DIMENSION(3) :: JTQ1, JTQ2 + END MODULE l1_C diff --git a/src/lib/libmod/l2_C.f90 b/src/lib/libmod/l2_C.f90 index 6026e6362..6bc8d3a4e 100644 --- a/src/lib/libmod/l2_C.f90 +++ b/src/lib/libmod/l2_C.f90 @@ -1,8 +1,8 @@ - MODULE l2_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE l2_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: MTRIAD = 12 - INTEGER, DIMENSION(MTRIAD,3) :: J2S, J3S - END MODULE l2_C + INTEGER, PARAMETER :: MTRIAD = 12 + INTEGER, DIMENSION(MTRIAD,3) :: J2S, J3S + END MODULE l2_C diff --git a/src/lib/libmod/lagr_C.f90 b/src/lib/libmod/lagr_C.f90 index c6d6152e3..12ebf0bb6 100644 --- a/src/lib/libmod/lagr_C.f90 +++ b/src/lib/libmod/lagr_C.f90 @@ -1,9 +1,9 @@ - MODULE lagr_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE lagr_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:37:37 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NEC + INTEGER :: NEC REAL(DOUBLE), DIMENSION(:), pointer :: ecv INTEGER, DIMENSION(:), pointer :: iecc - END MODULE lagr_C + END MODULE lagr_C diff --git a/src/lib/libmod/left_C.f90 b/src/lib/libmod/left_C.f90 index ca29a58d7..6c9d04141 100644 --- a/src/lib/libmod/left_C.f90 +++ b/src/lib/libmod/left_C.f90 @@ -1,8 +1,8 @@ - MODULE left_C - USE vast_kind_param, ONLY: DOUBLE + MODULE left_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL, DIMENSION(NNNW) :: SET - END MODULE left_C + LOGICAL, DIMENSION(NNNW) :: SET + END MODULE left_C diff --git a/src/lib/libmod/lib92p_C.f90 b/src/lib/libmod/lib92p_C.f90 index 809bbb1c2..d18809f94 100644 --- a/src/lib/libmod/lib92p_C.f90 +++ b/src/lib/libmod/lib92p_C.f90 @@ -1,7 +1,7 @@ - MODULE lib92p_C -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer + MODULE lib92p_C +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(4) :: NPLANT - LOGICAL :: LPLANT - END MODULE lib92p_C + INTEGER, DIMENSION(4) :: NPLANT + LOGICAL :: LPLANT + END MODULE lib92p_C diff --git a/src/lib/libmod/lic13_C.f90 b/src/lib/libmod/lic13_C.f90 index df4f6617c..ca1ca4e0d 100644 --- a/src/lib/libmod/lic13_C.f90 +++ b/src/lib/libmod/lic13_C.f90 @@ -1,7 +1,7 @@ - MODULE lic13_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 -!...Modified by Charlotte Froese Fischer + MODULE lic13_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 10:47:21 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(13,13) :: A - END MODULE lic13_C + REAL(DOUBLE), DIMENSION(13,13) :: A + END MODULE lic13_C diff --git a/src/lib/libmod/m_C.f90 b/src/lib/libmod/m_C.f90 index becf60a67..21ea7a938 100644 --- a/src/lib/libmod/m_C.f90 +++ b/src/lib/libmod/m_C.f90 @@ -1,15 +1,15 @@ ! !*********************************************************************** ! * - MODULE m_C - USE vast_kind_param, ONLY: DOUBLE + MODULE m_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(NNNW) :: NQ1, NQ2 + INTEGER, DIMENSION(NNNW) :: NQ1, NQ2 INTEGER, DIMENSION(NNNW) :: JJC1, JJC2 - INTEGER, DIMENSION(3,NNNW) :: JJQ1, JJQ2 - INTEGER, DIMENSION(NNNW) :: JLIST, KLIST - INTEGER :: NPEEL, NCORE - END MODULE m_C + INTEGER, DIMENSION(3,NNNW) :: JJQ1, JJQ2 + INTEGER, DIMENSION(NNNW) :: JLIST, KLIST + INTEGER :: NPEEL, NCORE + END MODULE m_C diff --git a/src/lib/libmod/mcp_C.f90 b/src/lib/libmod/mcp_C.f90 index 3b6dbf2f3..dc2309937 100644 --- a/src/lib/libmod/mcp_C.f90 +++ b/src/lib/libmod/mcp_C.f90 @@ -1,8 +1,8 @@ - MODULE mcp_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE mcp_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 14:35:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: KMAX - LOGICAL :: DIAG, LFORDR - END MODULE mcp_C + INTEGER :: KMAX + LOGICAL :: DIAG, LFORDR + END MODULE mcp_C diff --git a/src/lib/libmod/mcpa_C.f90 b/src/lib/libmod/mcpa_C.f90 index 0ae10c108..6eff61ee5 100644 --- a/src/lib/libmod/mcpa_C.f90 +++ b/src/lib/libmod/mcpa_C.f90 @@ -1,7 +1,7 @@ - MODULE mcpa_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 13:49:35 1/ 5/07 -!...Modified by Charlotte Froese Fischer + MODULE mcpa_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 13:49:35 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: KMAXF - END MODULE mcpa_C + INTEGER :: KMAXF + END MODULE mcpa_C diff --git a/src/lib/libmod/mcpb_C.f90 b/src/lib/libmod/mcpb_C.f90 index 977fe40d8..e39c1f23f 100644 --- a/src/lib/libmod/mcpb_C.f90 +++ b/src/lib/libmod/mcpb_C.f90 @@ -1,7 +1,7 @@ - MODULE mcpb_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 13:49:35 1/ 5/07 -!...Modified by Charlotte Froese Fischer + MODULE mcpb_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 13:49:35 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL :: DIAG, LFORDR - END MODULE mcpb_C + LOGICAL :: DIAG, LFORDR + END MODULE mcpb_C diff --git a/src/lib/libmod/mcpdata_C.f90 b/src/lib/libmod/mcpdata_C.f90 index 84605ff70..6dcd37bc3 100644 --- a/src/lib/libmod/mcpdata_C.f90 +++ b/src/lib/libmod/mcpdata_C.f90 @@ -1,9 +1,9 @@ - MODULE mcpdata_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE mcpdata_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER :: NCOEFF, NINTG INTEGER, DIMENSION(:), pointer :: jann, jbnn, intgrl, intptr REAL(DOUBLE), DIMENSION(:), pointer :: cnn - END MODULE mcpdata_C + END MODULE mcpdata_C diff --git a/src/lib/libmod/memory_man.f90 b/src/lib/libmod/memory_man.f90 index 2f392c374..022b1aae4 100644 --- a/src/lib/libmod/memory_man.f90 +++ b/src/lib/libmod/memory_man.f90 @@ -24,7 +24,7 @@ MODULE memory_man END INTERFACE CONTAINS - SUBROUTINE alloc_0i(p, first, last, var, sub ) + SUBROUTINE alloc_0i(p, first, last, var, sub ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: first, last @@ -48,7 +48,7 @@ SUBROUTINE alloc_0i(p, first, last, var, sub ) END IF END SUBROUTINE alloc_0i - SUBROUTINE alloc_1i(p, n, var, sub) + SUBROUTINE alloc_1i(p, n, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -72,7 +72,7 @@ SUBROUTINE alloc_1i(p, n, var, sub) END IF END SUBROUTINE alloc_1i - SUBROUTINE alloc_2i(p, n1, n2, var, sub) + SUBROUTINE alloc_2i(p, n1, n2, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -143,8 +143,8 @@ SUBROUTINE alloc_1iL(p, n, var, sub) END IF END IF END SUBROUTINE alloc_1iL - - SUBROUTINE alloc_1r(p, n, var, sub) + + SUBROUTINE alloc_1r(p, n, var, sub) IMPLICIT NONE real(double), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -168,7 +168,7 @@ SUBROUTINE alloc_1r(p, n, var, sub) END IF END SUBROUTINE alloc_1r - SUBROUTINE alloc_2r(p, n1, n2, var, sub) + SUBROUTINE alloc_2r(p, n1, n2, var, sub) IMPLICIT NONE REAL(double), POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -216,7 +216,7 @@ SUBROUTINE alloc_1rL(p, n, var, sub) END IF END SUBROUTINE alloc_1rL - SUBROUTINE alloc_0b(p, first, last, var, sub ) + SUBROUTINE alloc_0b(p, first, last, var, sub ) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: first, last @@ -240,7 +240,7 @@ SUBROUTINE alloc_0b(p, first, last, var, sub ) END IF END SUBROUTINE alloc_0b - SUBROUTINE alloc_1b(p, n, var, sub) + SUBROUTINE alloc_1b(p, n, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -264,7 +264,7 @@ SUBROUTINE alloc_1b(p, n, var, sub) END IF END SUBROUTINE alloc_1b - SUBROUTINE alloc_2b(p, n1, n2, var, sub) + SUBROUTINE alloc_2b(p, n1, n2, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -312,7 +312,7 @@ SUBROUTINE alloc_3b(p, n1, n2, n3, var, sub) END IF END SUBROUTINE alloc_3b - SUBROUTINE alloc_1c(p, n, var, sub) + SUBROUTINE alloc_1c(p, n, var, sub) IMPLICIT NONE !CFF CHARACTER(LEN=256), POINTER, DIMENSION(:) :: p CHARACTER(LEN=*), POINTER, DIMENSION(:) :: p @@ -482,7 +482,7 @@ SUBROUTINE ralloc_0i(p, first, last, var, sub) END SUBROUTINE ralloc_0i - SUBROUTINE ralloc_1i(p, n, var, sub) + SUBROUTINE ralloc_1i(p, n, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -508,7 +508,7 @@ SUBROUTINE ralloc_1i(p, n, var, sub) END IF END SUBROUTINE ralloc_1i - SUBROUTINE ralloc_2i(p, n1, n2, var, sub) + SUBROUTINE ralloc_2i(p, n1, n2, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -535,8 +535,8 @@ SUBROUTINE ralloc_2i(p, n1, n2, var, sub) p => pnew END IF END SUBROUTINE ralloc_2i - - SUBROUTINE ralloc_3i(p, n1, n2, n3, var, sub) + + SUBROUTINE ralloc_3i(p, n1, n2, n3, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2, n3 @@ -564,8 +564,8 @@ SUBROUTINE ralloc_3i(p, n1, n2, n3, var, sub) p => pnew END IF END SUBROUTINE ralloc_3i - - SUBROUTINE ralloc_1r(p, n, var, sub) + + SUBROUTINE ralloc_1r(p, n, var, sub) IMPLICIT NONE real(double), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -592,7 +592,7 @@ SUBROUTINE ralloc_1r(p, n, var, sub) END IF END SUBROUTINE ralloc_1r - SUBROUTINE ralloc_2r(p, n1, n2, var, sub) + SUBROUTINE ralloc_2r(p, n1, n2, var, sub) IMPLICIT NONE REAL(double), POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -616,7 +616,7 @@ SUBROUTINE ralloc_2r(p, n1, n2, var, sub) n2_old = MIN(SIZE(p, DIM=2),n2) pnew(1:n1_old, 1:n2_old) = p(1:n1_old, 1:n2_old) DEALLOCATE(p) - p => pnew + p => pnew END IF END SUBROUTINE ralloc_2r @@ -647,7 +647,7 @@ SUBROUTINE ralloc_0b(p, first, last, var, sub) END IF END SUBROUTINE ralloc_0b - SUBROUTINE ralloc_1b(p, n, var, sub) + SUBROUTINE ralloc_1b(p, n, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -673,7 +673,7 @@ SUBROUTINE ralloc_1b(p, n, var, sub) END IF END SUBROUTINE ralloc_1b - SUBROUTINE ralloc_2b(p, n1, n2, var, sub) + SUBROUTINE ralloc_2b(p, n1, n2, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -700,8 +700,8 @@ SUBROUTINE ralloc_2b(p, n1, n2, var, sub) p => pnew END IF END SUBROUTINE ralloc_2b - - SUBROUTINE ralloc_3b(p, n1, n2, n3, var, sub) + + SUBROUTINE ralloc_3b(p, n1, n2, n3, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2, n3 @@ -733,8 +733,8 @@ SUBROUTINE ralloc_3b(p, n1, n2, n3, var, sub) p => pnew END IF END SUBROUTINE ralloc_3b - - SUBROUTINE ralloc_1c(p, n, var, sub) + + SUBROUTINE ralloc_1c(p, n, var, sub) IMPLICIT NONE CHARACTER(LEN=256), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n diff --git a/src/lib/libmod/memory_man.f90_PROFILING b/src/lib/libmod/memory_man.f90_PROFILING old mode 100755 new mode 100644 index 21b38ce56..f611f06eb --- a/src/lib/libmod/memory_man.f90_PROFILING +++ b/src/lib/libmod/memory_man.f90_PROFILING @@ -24,7 +24,7 @@ MODULE memory_man END INTERFACE CONTAINS - SUBROUTINE alloc_0i(p, first, last, var, sub ) + SUBROUTINE alloc_0i(p, first, last, var, sub ) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: first, last @@ -47,7 +47,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_0i - SUBROUTINE alloc_1i(p, n, var, sub) + SUBROUTINE alloc_1i(p, n, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -70,7 +70,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_1i - SUBROUTINE alloc_2i(p, n1, n2, var, sub) + SUBROUTINE alloc_2i(p, n1, n2, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -138,8 +138,8 @@ MODULE memory_man END IF END IF END SUBROUTINE alloc_1iL - - SUBROUTINE alloc_1r(p, n, var, sub) + + SUBROUTINE alloc_1r(p, n, var, sub) IMPLICIT NONE real(double), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -162,7 +162,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_1r - SUBROUTINE alloc_2r(p, n1, n2, var, sub) + SUBROUTINE alloc_2r(p, n1, n2, var, sub) IMPLICIT NONE REAL(double), POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -208,7 +208,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_1rL - SUBROUTINE alloc_0b(p, first, last, var, sub ) + SUBROUTINE alloc_0b(p, first, last, var, sub ) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: first, last @@ -231,7 +231,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_0b - SUBROUTINE alloc_1b(p, n, var, sub) + SUBROUTINE alloc_1b(p, n, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -254,7 +254,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_1b - SUBROUTINE alloc_2b(p, n1, n2, var, sub) + SUBROUTINE alloc_2b(p, n1, n2, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:) :: p INTEGER, INTENT(IN) :: n1, n2 @@ -300,7 +300,7 @@ MODULE memory_man END IF END SUBROUTINE alloc_3b - SUBROUTINE alloc_1c(p, n, var, sub) + SUBROUTINE alloc_1c(p, n, var, sub) IMPLICIT NONE CHARACTER(LEN=256), POINTER, DIMENSION(:) :: p INTEGER, INTENT(IN) :: n @@ -469,7 +469,7 @@ MODULE memory_man END SUBROUTINE ralloc_0i - SUBROUTINE ralloc_1i(p, n, var, sub) + SUBROUTINE ralloc_1i(p, n, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -495,7 +495,7 @@ MODULE memory_man END IF END SUBROUTINE ralloc_1i - SUBROUTINE ralloc_2i(p, n1, n2, var, sub) + SUBROUTINE ralloc_2i(p, n1, n2, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -522,8 +522,8 @@ MODULE memory_man p => pnew END IF END SUBROUTINE ralloc_2i - - SUBROUTINE ralloc_3i(p, n1, n2, n3, var, sub) + + SUBROUTINE ralloc_3i(p, n1, n2, n3, var, sub) IMPLICIT NONE INTEGER, POINTER, DIMENSION(:,:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2, n3 @@ -551,8 +551,8 @@ MODULE memory_man p => pnew END IF END SUBROUTINE ralloc_3i - - SUBROUTINE ralloc_1r(p, n, var, sub) + + SUBROUTINE ralloc_1r(p, n, var, sub) IMPLICIT NONE real(double), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -579,7 +579,7 @@ MODULE memory_man END IF END SUBROUTINE ralloc_1r - SUBROUTINE ralloc_2r(p, n1, n2, var, sub) + SUBROUTINE ralloc_2r(p, n1, n2, var, sub) IMPLICIT NONE REAL(double), POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -603,7 +603,7 @@ MODULE memory_man n2_old = MIN(SIZE(p, DIM=2),n2) pnew(1:n1_old, 1:n2_old) = p(1:n1_old, 1:n2_old) DEALLOCATE(p) - p => pnew + p => pnew END IF END SUBROUTINE ralloc_2r @@ -634,7 +634,7 @@ MODULE memory_man END IF END SUBROUTINE ralloc_0b - SUBROUTINE ralloc_1b(p, n, var, sub) + SUBROUTINE ralloc_1b(p, n, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n @@ -660,7 +660,7 @@ MODULE memory_man END IF END SUBROUTINE ralloc_1b - SUBROUTINE ralloc_2b(p, n1, n2, var, sub) + SUBROUTINE ralloc_2b(p, n1, n2, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2 @@ -687,8 +687,8 @@ MODULE memory_man p => pnew END IF END SUBROUTINE ralloc_2b - - SUBROUTINE ralloc_3b(p, n1, n2, n3, var, sub) + + SUBROUTINE ralloc_3b(p, n1, n2, n3, var, sub) IMPLICIT NONE INTEGER(BYTE), POINTER, DIMENSION(:,:,:) :: p, pnew INTEGER, INTENT(IN) :: n1, n2, n3 @@ -720,8 +720,8 @@ MODULE memory_man p => pnew END IF END SUBROUTINE ralloc_3b - - SUBROUTINE ralloc_1c(p, n, var, sub) + + SUBROUTINE ralloc_1c(p, n, var, sub) IMPLICIT NONE CHARACTER(LEN=256), POINTER, DIMENSION(:) :: p, pnew INTEGER, INTENT(IN) :: n diff --git a/src/lib/libmod/ncc_C.f90 b/src/lib/libmod/ncc_C.f90 index a80e16ba8..cb08648a4 100644 --- a/src/lib/libmod/ncc_C.f90 +++ b/src/lib/libmod/ncc_C.f90 @@ -1,7 +1,7 @@ - MODULE ncc_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE ncc_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE) :: C1, C2, C3, C4 + REAL(DOUBLE) :: C1, C2, C3, C4 END MODULE ncc_C diff --git a/src/lib/libmod/ncdist_C.f90 b/src/lib/libmod/ncdist_C.f90 index 7eed29341..1bd0ac6cc 100644 --- a/src/lib/libmod/ncdist_C.f90 +++ b/src/lib/libmod/ncdist_C.f90 @@ -1,8 +1,8 @@ - MODULE ncdist_C - USE vast_kind_param, ONLY: DOUBLE + MODULE ncdist_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(NNNP) :: ZDIST - END MODULE ncdist_C + REAL(DOUBLE), DIMENSION(NNNP) :: ZDIST + END MODULE ncdist_C diff --git a/src/lib/libmod/node_C.f90 b/src/lib/libmod/node_C.f90 index 5c0314277..808669699 100644 --- a/src/lib/libmod/node_C.f90 +++ b/src/lib/libmod/node_C.f90 @@ -1,7 +1,7 @@ - MODULE node_C + MODULE node_C USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(NNNW) :: NNODEP - END MODULE node_C + INTEGER, DIMENSION(NNNW) :: NNODEP + END MODULE node_C diff --git a/src/lib/libmod/npar_C.f90 b/src/lib/libmod/npar_C.f90 index c196bb260..f8496bc8a 100644 --- a/src/lib/libmod/npar_C.f90 +++ b/src/lib/libmod/npar_C.f90 @@ -1,23 +1,23 @@ ! !*********************************************************************** ! * - MODULE npar_C + MODULE npar_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 -!...Modified by Charlotte Froese Fischer + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NPARM - REAL(DOUBLE), DIMENSION(2) :: PARM - END MODULE npar_C + INTEGER :: NPARM + REAL(DOUBLE), DIMENSION(2) :: PARM + END MODULE npar_C - MODULE nsmdat_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE nsmdat_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:36:34 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE) :: SQN,DMOMNM,QMOMB - REAL(DOUBLE) :: HFSI, HFSD, HFSQ - REAL(DOUBLE) :: SMSI, SMSD, SMSQ - END MODULE nsmdat_C + REAL(DOUBLE) :: HFSI, HFSD, HFSQ + REAL(DOUBLE) :: SMSI, SMSD, SMSQ + END MODULE nsmdat_C diff --git a/src/lib/libmod/npot_C.f90 b/src/lib/libmod/npot_C.f90 index 688d6f41c..56aea43c9 100644 --- a/src/lib/libmod/npot_C.f90 +++ b/src/lib/libmod/npot_C.f90 @@ -1,9 +1,9 @@ - MODULE npot_C - USE vast_kind_param, ONLY: DOUBLE + MODULE npot_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NNUC - REAL(DOUBLE), DIMENSION(NNNP) :: ZZ - END MODULE npot_C + INTEGER :: NNUC + REAL(DOUBLE), DIMENSION(NNNP) :: ZZ + END MODULE npot_C diff --git a/src/lib/libmod/offd_C.f90 b/src/lib/libmod/offd_C.f90 index 4fb140774..51b3cd103 100644 --- a/src/lib/libmod/offd_C.f90 +++ b/src/lib/libmod/offd_C.f90 @@ -1,6 +1,6 @@ - MODULE offd_C -!...Created by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE offd_C +!...Created by Pacific-Sierra Research 77to90 4.3E 07:16:10 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NOFFD1, NOFFD2 - END MODULE offd_C + INTEGER :: NOFFD1, NOFFD2 + END MODULE offd_C diff --git a/src/lib/libmod/orb_C.f90 b/src/lib/libmod/orb_C.f90 index 1a53873bd..d2b45e9f0 100644 --- a/src/lib/libmod/orb_C.f90 +++ b/src/lib/libmod/orb_C.f90 @@ -1,21 +1,21 @@ ! !*********************************************************************** ! * - MODULE orb_C + MODULE orb_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE, BYTE + USE vast_kind_param, ONLY: DOUBLE, BYTE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 08:57:22 12/25/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 08:57:22 12/25/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - CHARACTER(LEN=2), DIMENSION(NNNW) :: NH - CHARACTER(LEN=2), DIMENSION(NNNW) :: NHR + CHARACTER(LEN=2), DIMENSION(NNNW) :: NH + CHARACTER(LEN=2), DIMENSION(NNNW) :: NHR REAL(DOUBLE), DIMENSION(NNNW) :: E, GAMA, PED - INTEGER :: NCF, NW, NCFR, NWR + INTEGER :: NCF, NW, NCFR, NWR INTEGER(BYTE), DIMENSION(:,:), pointer :: IQA INTEGER, DIMENSION(:,:), pointer :: IQAR - INTEGER, DIMENSION(NNNW) :: NP, NAK, NPR, NAKR - INTEGER, DIMENSION(NNNW) :: NKL, NKJ - END MODULE orb_C + INTEGER, DIMENSION(NNNW) :: NP, NAK, NPR, NAKR + INTEGER, DIMENSION(NNNW) :: NKL, NKJ + END MODULE orb_C diff --git a/src/lib/libmod/orba_C.f90 b/src/lib/libmod/orba_C.f90 index 9999946b9..616b47ece 100644 --- a/src/lib/libmod/orba_C.f90 +++ b/src/lib/libmod/orba_C.f90 @@ -1,8 +1,8 @@ - MODULE orba_C - USE vast_kind_param, ONLY: DOUBLE + MODULE orba_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 14:16:00 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(NNNW) :: IORDER - END MODULE orba_C + INTEGER, DIMENSION(NNNW) :: IORDER + END MODULE orba_C diff --git a/src/lib/libmod/orbord_C.f90 b/src/lib/libmod/orbord_C.f90 index e46bd43a0..850ad4d8f 100644 --- a/src/lib/libmod/orbord_C.f90 +++ b/src/lib/libmod/orbord_C.f90 @@ -1,6 +1,6 @@ - MODULE orbord_C -!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE orbord_C +!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NORDII, NORDFF - END MODULE orbord_C + INTEGER :: NORDII, NORDFF + END MODULE orbord_C diff --git a/src/lib/libmod/orthct_C.f90 b/src/lib/libmod/orthct_C.f90 index f5d1e3acb..226ae9aa2 100644 --- a/src/lib/libmod/orthct_C.f90 +++ b/src/lib/libmod/orthct_C.f90 @@ -1,6 +1,6 @@ - MODULE orthct_C -!...Created by Pacific-Sierra Research 77to90 4.3E 13:56:39 1/ 3/07 -!...Modified by Charlotte Froese Fischer + MODULE orthct_C +!...Created by Pacific-Sierra Research 77to90 4.3E 13:56:39 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - LOGICAL :: ORTHST - END MODULE orthct_C + LOGICAL :: ORTHST + END MODULE orthct_C diff --git a/src/lib/libmod/osc_C.f90 b/src/lib/libmod/osc_C.f90 index 8b657ede0..beb442931 100644 --- a/src/lib/libmod/osc_C.f90 +++ b/src/lib/libmod/osc_C.f90 @@ -1,18 +1,18 @@ - MODULE osc_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE osc_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 07:26:50 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NSDIM + INTEGER :: NSDIM REAL(DOUBLE), DIMENSION(:), pointer :: hb1, hb2, hc1, hc2, hm1, hm2 INTEGER, DIMENSION(:), pointer :: jja, jjb - INTEGER :: LK, KK - INTEGER :: NTDIM + INTEGER :: LK, KK + INTEGER :: NTDIM REAL(DOUBLE), DIMENSION(:), pointer :: xsldr, totc, totb INTEGER, DIMENSION(:), pointer :: isldr, isldr1 - INTEGER :: NINT, NINTEG + INTEGER :: NINT, NINTEG INTEGER, DIMENSION(:), pointer :: nptr, lab - INTEGER :: NKP + INTEGER :: NKP INTEGER, DIMENSION(:), pointer :: kp - LOGICAL, DIMENSION(10) :: LTC - END MODULE osc_C + LOGICAL, DIMENSION(10) :: LTC + END MODULE osc_C diff --git a/src/lib/libmod/ovl_C.f90 b/src/lib/libmod/ovl_C.f90 index b1b18edb1..5dcdf259d 100644 --- a/src/lib/libmod/ovl_C.f90 +++ b/src/lib/libmod/ovl_C.f90 @@ -1,7 +1,7 @@ - MODULE ovl_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE ovl_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 16:54:29 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NOVL - END MODULE ovl_C + INTEGER :: NOVL + END MODULE ovl_C diff --git a/src/lib/libmod/parameter_def_M.f90 b/src/lib/libmod/parameter_def_M.f90 index 996aa826d..6dc82156d 100644 --- a/src/lib/libmod/parameter_def_M.f90 +++ b/src/lib/libmod/parameter_def_M.f90 @@ -2,22 +2,22 @@ module parameter_def ! THis module defines some global parameters for the ! application -!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/15/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 11:01:42 1/15/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !==================================================================== -! KEYORB: Is a packing parameter defined by a packing algorithm. -! This is the largest integer for which KEYORB**4 < 2^31 +! KEYORB: Is a packing parameter defined by a packing algorithm. +! This is the largest integer for which KEYORB**4 < 2^31 ! (the largest positive INTEGER*4) -! NNNP: Number of points in the radial grid -! NNN1: = NNNP+10 -! NNNW Maximum number or orbitals (previously 120). An n=10 +! NNNP: Number of points in the radial grid +! NNN1: = NNNP+10 +! NNNW Maximum number or orbitals (previously 120). An n=10 ! calculation has 100 orbitals. This parameter is used ! to assign array dimensions such as NNNW*NCFG where ! NCFG is the total number of CSFs. ! NNNWM1: = NNNW-1 ! NNNWM2: = NNNW-2 -!------------------------------------------------------------------ +!------------------------------------------------------------------ integer, parameter :: KEYORB = 215 integer, parameter :: NNNP = 590 diff --git a/src/lib/libmod/peav_C.f90 b/src/lib/libmod/peav_C.f90 index 8990666c0..9d05d8b29 100644 --- a/src/lib/libmod/peav_C.f90 +++ b/src/lib/libmod/peav_C.f90 @@ -1,7 +1,7 @@ - MODULE peav_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE peav_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE), DIMENSION(:), pointer :: eavblk - END MODULE peav_C + END MODULE peav_C diff --git a/src/lib/libmod/pos_C.f90 b/src/lib/libmod/pos_C.f90 index 07a987f8c..c44539799 100644 --- a/src/lib/libmod/pos_C.f90 +++ b/src/lib/libmod/pos_C.f90 @@ -1,10 +1,10 @@ - MODULE pos_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE pos_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NCFTOT, NVECSIZ + INTEGER :: NCFTOT, NVECSIZ INTEGER, DIMENSION(:), pointer :: ncfpast INTEGER, DIMENSION(:), pointer :: ncminpast, nevecpast - - END MODULE pos_C + + END MODULE pos_C diff --git a/src/lib/libmod/pote_C.f90 b/src/lib/libmod/pote_C.f90 index 1e9b77874..d8fbc989d 100644 --- a/src/lib/libmod/pote_C.f90 +++ b/src/lib/libmod/pote_C.f90 @@ -1,8 +1,8 @@ - MODULE pote_C - USE vast_kind_param, ONLY: DOUBLE + MODULE pote_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(NNNP) :: YP, XP, XQ - END MODULE pote_C + REAL(DOUBLE), DIMENSION(NNNP) :: YP, XP, XQ + END MODULE pote_C diff --git a/src/lib/libmod/prnt_C.f90 b/src/lib/libmod/prnt_C.f90 index f4964e3ca..2005edb28 100644 --- a/src/lib/libmod/prnt_C.f90 +++ b/src/lib/libmod/prnt_C.f90 @@ -1,16 +1,16 @@ ! !*********************************************************************** ! * - MODULE prnt_C + MODULE prnt_C ! * !*********************************************************************** USE vast_kind_param, ONLY: DOUBLE, BYTE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NVEC, NVECMX - INTEGER :: NVECFF, NVECMXFF - INTEGER :: NVECII, NVECMXII - REAL(DOUBLE) :: PNIVECII + INTEGER :: NVEC, NVECMX + INTEGER :: NVECFF, NVECMXFF + INTEGER :: NVECII, NVECMXII + REAL(DOUBLE) :: PNIVECII INTEGER, DIMENSION(:), pointer :: ivec, ivecff, ivecii - END MODULE prnt_C + END MODULE prnt_C diff --git a/src/lib/libmod/qedcut_C.f90 b/src/lib/libmod/qedcut_C.f90 index 201059f8f..75b723b3c 100644 --- a/src/lib/libmod/qedcut_C.f90 +++ b/src/lib/libmod/qedcut_C.f90 @@ -1,3 +1,3 @@ - MODULE qedcut_C + MODULE qedcut_C INTEGER :: NQEDCUT, NQEDMAX - END MODULE qedcut_C + END MODULE qedcut_C diff --git a/src/lib/libmod/rang_Int_C.f90 b/src/lib/libmod/rang_Int_C.f90 index 175b3c20d..a5b8c5817 100644 --- a/src/lib/libmod/rang_Int_C.f90 +++ b/src/lib/libmod/rang_Int_C.f90 @@ -1,8 +1,8 @@ - MODULE rang_Int_C -!...Modified by Charlotte Froese Fischer + MODULE rang_Int_C +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER :: NotFound, Found_CSF INTEGER, DIMENSION(:), pointer :: Found CHARACTER(LEN=256), DIMENSION(:), pointer :: C_shell, C_quant, C_coupl INTEGER, DIMENSION(20) :: NUM_in_BLK - END MODULE rang_Int_C + END MODULE rang_Int_C diff --git a/src/lib/libmod/ribojj11_C.f90 b/src/lib/libmod/ribojj11_C.f90 index f8d3999e2..045c0655a 100644 --- a/src/lib/libmod/ribojj11_C.f90 +++ b/src/lib/libmod/ribojj11_C.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - MODULE ribojj11_C + MODULE ribojj11_C ! * ! This module is need for librang90. * ! * @@ -8,7 +8,7 @@ MODULE ribojj11_C ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! * !******************************************************************* -! +! IMPLICIT NONE INTEGER, DIMENSION(189) :: IMPTJJ11, IMGTJJ11, IMPNJJ11, IMGNJJ11 DATA IMPTJJ11/1,6*2,8,7*9,16,8*17,25,9*26,35,10*36, & @@ -23,4 +23,4 @@ MODULE ribojj11_C DATA IMGNJJ11/7,6*1,15,7*8,24,8*16,34,9*25,45,10*35, & 57,11*46,70,12*58,84,13*71,99,14*85,115,15*100, & 132,16*116,150,17*133,169,18*151,189,19*100/ - END MODULE ribojj11_C + END MODULE ribojj11_C diff --git a/src/lib/libmod/ribojj9_C.f90 b/src/lib/libmod/ribojj9_C.f90 index bff32dc36..540aea0a2 100644 --- a/src/lib/libmod/ribojj9_C.f90 +++ b/src/lib/libmod/ribojj9_C.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - MODULE ribojj9_C + MODULE ribojj9_C ! * ! This module is need for librang90. * ! * @@ -8,11 +8,11 @@ MODULE ribojj9_C ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! * !******************************************************************* -! +! IMPLICIT NONE INTEGER, DIMENSION(6) :: IMPTJJ9, IMGTJJ9, IMPNJJ9, IMGNJJ9 DATA IMPTJJ9/301,5*302/ DATA IMGTJJ9/301,5*306/ DATA IMPNJJ9/302,5*301/ DATA IMGNJJ9/306,5*301/ - END MODULE ribojj9_C + END MODULE ribojj9_C diff --git a/src/lib/libmod/ribojj_C.f90 b/src/lib/libmod/ribojj_C.f90 index e66442f42..c18c594a6 100644 --- a/src/lib/libmod/ribojj_C.f90 +++ b/src/lib/libmod/ribojj_C.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - MODULE ribojj_C + MODULE ribojj_C ! * ! This module is need for librang90. * ! * @@ -8,11 +8,11 @@ MODULE ribojj_C ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! * !******************************************************************* -! +! IMPLICIT NONE INTEGER, DIMENSION(63) :: IMPTJJ, IMGTJJ, IMPNJJ, IMGNJJ DATA IMPNJJ/2,1,4,2*3,3*9,3*6,6*18,8*12,20*46,18*26/ DATA IMGNJJ/2,1,5,2*3,3*11,3*8,6*25,8*17,20*63,18*45/ DATA IMPTJJ/1,2,3,2*4,3*6,3*9,6*12,8*18,20*26,18*46/ DATA IMGTJJ/1,2,3,2*5,3*8,3*11,6*17,8*25,20*45,18*63/ - END MODULE ribojj_C + END MODULE ribojj_C diff --git a/src/lib/libmod/sacoef_C.f90 b/src/lib/libmod/sacoef_C.f90 index d7d92aeb7..e56b87252 100644 --- a/src/lib/libmod/sacoef_C.f90 +++ b/src/lib/libmod/sacoef_C.f90 @@ -8,7 +8,7 @@ MODULE sacoef_C ! NIST last update: May 2017 * ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE ! REAL(DOUBLE), DIMENSION(:,:), pointer :: TCOEFF INTEGER, DIMENSION(:,:), pointer :: IICLMN, IINDEX, ILABEL diff --git a/src/lib/libmod/sbc_C.f90 b/src/lib/libmod/sbc_C.f90 index 9746695bb..6176eacfd 100644 --- a/src/lib/libmod/sbc_C.f90 +++ b/src/lib/libmod/sbc_C.f90 @@ -1,7 +1,7 @@ - MODULE sbc_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer + MODULE sbc_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 REAL(DOUBLE), DIMENSION(6) :: C - END MODULE sbc_C + END MODULE sbc_C diff --git a/src/lib/libmod/sbdat1_C.f90 b/src/lib/libmod/sbdat1_C.f90 index 4cfee4f94..3f6d42504 100644 --- a/src/lib/libmod/sbdat1_C.f90 +++ b/src/lib/libmod/sbdat1_C.f90 @@ -1,10 +1,10 @@ - MODULE sbdat1_C - USE vast_kind_param, ONLY: DOUBLE + MODULE sbdat1_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:25:32 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: NLMAX = 20 - INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLP - INTEGER, DIMENSION(NLMAX,NNNW) :: NSHLPP - END MODULE sbdat1_C + INTEGER, PARAMETER :: NLMAX = 20 + INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLP + INTEGER, DIMENSION(NLMAX,NNNW) :: NSHLPP + END MODULE sbdat1_C diff --git a/src/lib/libmod/sbdat_C.f90 b/src/lib/libmod/sbdat_C.f90 index 8afd55fb1..3093cc293 100644 --- a/src/lib/libmod/sbdat_C.f90 +++ b/src/lib/libmod/sbdat_C.f90 @@ -1,16 +1,16 @@ - MODULE sbdat_C + MODULE sbdat_C USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:27:59 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, PARAMETER :: NLMAX = 20 - INTEGER, DIMENSION(NNNW) :: NAKINVII - INTEGER, DIMENSION(NLMAX) :: NSHLII - INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLPII - INTEGER, DIMENSION(NNNW) :: NAKINVFF - INTEGER, DIMENSION(NLMAX) :: NSHLFF - INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLPFF - INTEGER, DIMENSION(NLMAX,NNNW) :: NSHLPPII, NSHLPPFF - INTEGER, DIMENSION(NLMAX) :: NINII, NINFF, IKAPPA - INTEGER :: KAMAX - END MODULE sbdat_C + INTEGER, PARAMETER :: NLMAX = 20 + INTEGER, DIMENSION(NNNW) :: NAKINVII + INTEGER, DIMENSION(NLMAX) :: NSHLII + INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLPII + INTEGER, DIMENSION(NNNW) :: NAKINVFF + INTEGER, DIMENSION(NLMAX) :: NSHLFF + INTEGER, DIMENSION(NLMAX,NLMAX) :: NSHLPFF + INTEGER, DIMENSION(NLMAX,NNNW) :: NSHLPPII, NSHLPPFF + INTEGER, DIMENSION(NLMAX) :: NINII, NINFF, IKAPPA + INTEGER :: KAMAX + END MODULE sbdat_C diff --git a/src/lib/libmod/scf_C.f90 b/src/lib/libmod/scf_C.f90 index d119775f4..33fdb72e7 100644 --- a/src/lib/libmod/scf_C.f90 +++ b/src/lib/libmod/scf_C.f90 @@ -1,14 +1,14 @@ - MODULE scf_C - USE vast_kind_param, ONLY: DOUBLE + MODULE scf_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:38:40 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE), DIMENSION(NNNW) :: UCF - INTEGER, DIMENSION(NNNW) :: METHOD - REAL(DOUBLE), DIMENSION(NNNW) :: SCNSTY - REAL(DOUBLE) :: EPSMIN, EPSMAX, EMIN, EMAX, ZINF - INTEGER :: NDCOF, NXCOF, NYCOF, NDDIM, NXDIM, NYDIM - REAL(DOUBLE), DIMENSION(:), pointer :: da, xa, ya + REAL(DOUBLE), DIMENSION(NNNW) :: UCF + INTEGER, DIMENSION(NNNW) :: METHOD + REAL(DOUBLE), DIMENSION(NNNW) :: SCNSTY + REAL(DOUBLE) :: EPSMIN, EPSMAX, EMIN, EMAX, ZINF + INTEGER :: NDCOF, NXCOF, NYCOF, NDDIM, NXDIM, NYDIM + REAL(DOUBLE), DIMENSION(:), pointer :: da, xa, ya INTEGER, DIMENSION(:), pointer :: nda, nxa, nya - END MODULE scf_C + END MODULE scf_C diff --git a/src/lib/libmod/stat_C.f90 b/src/lib/libmod/stat_C.f90 index afa7759ca..80f4d6620 100644 --- a/src/lib/libmod/stat_C.f90 +++ b/src/lib/libmod/stat_C.f90 @@ -1,16 +1,16 @@ ! !*********************************************************************** ! * - MODULE stat_C + MODULE stat_C ! !*********************************************************************** ! * USE vast_kind_param, ONLY: DOUBLE, BYTE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 07:21:55 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(:,:,:), pointer :: jqsar INTEGER(BYTE), DIMENSION(:,:,:), pointer :: jqsa INTEGER, DIMENSION(:,:), pointer :: jcupar INTEGER(BYTE), DIMENSION(:,:), pointer :: jcupa - END MODULE stat_C + END MODULE stat_C diff --git a/src/lib/libmod/stor_C.f90 b/src/lib/libmod/stor_C.f90 index ebd63e482..cfc09bc61 100644 --- a/src/lib/libmod/stor_C.f90 +++ b/src/lib/libmod/stor_C.f90 @@ -1,7 +1,7 @@ - MODULE stor_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE stor_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(2,2) :: KEEP - END MODULE stor_C + INTEGER, DIMENSION(2,2) :: KEEP + END MODULE stor_C diff --git a/src/lib/libmod/syma_C.f90 b/src/lib/libmod/syma_C.f90 index 37cf332ca..9aca42652 100644 --- a/src/lib/libmod/syma_C.f90 +++ b/src/lib/libmod/syma_C.f90 @@ -1,16 +1,16 @@ ! !*********************************************************************** ! * - MODULE syma_C + MODULE syma_C ! * !*********************************************************************** - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE INTEGER, PARAMETER::nblk0 = 50 ! Maximum number of blocks -!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 INTEGER, DIMENSION(:), pointer :: iatjpo, iaspar INTEGER, DIMENSION(:), pointer :: iatjpoff, iasparff INTEGER, DIMENSION(:), pointer :: iatjpoii, iasparii INTEGER, DIMENSION(nblk0) :: jpgg - END MODULE syma_C + END MODULE syma_C diff --git a/src/lib/libmod/tatb_C.f90 b/src/lib/libmod/tatb_C.f90 index 35876321e..54262151f 100644 --- a/src/lib/libmod/tatb_C.f90 +++ b/src/lib/libmod/tatb_C.f90 @@ -1,9 +1,9 @@ - MODULE tatb_C - USE vast_kind_param, ONLY: DOUBLE + MODULE tatb_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNN1 -!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: MTP - REAL(DOUBLE), DIMENSION(NNN1) :: TA, TB + INTEGER :: MTP + REAL(DOUBLE), DIMENSION(NNN1) :: TA, TB END MODULE tatb_C diff --git a/src/lib/libmod/terms_C.f90 b/src/lib/libmod/terms_C.f90 index ee44042a9..d21c7c54c 100644 --- a/src/lib/libmod/terms_C.f90 +++ b/src/lib/libmod/terms_C.f90 @@ -1,16 +1,16 @@ ! !*********************************************************************** ! * - MODULE terms_C + MODULE terms_C ! * !*********************************************************************** -!...Created by Pacific-Sierra Research 77to90 4.3E 06:16:25 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 06:16:25 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 implicit none - INTEGER, DIMENSION(31) :: ITAB - INTEGER, DIMENSION(32) :: JTAB - INTEGER, DIMENSION(327) :: NTAB + INTEGER, DIMENSION(31) :: ITAB + INTEGER, DIMENSION(32) :: JTAB + INTEGER, DIMENSION(327) :: NTAB INTEGER :: NROWS INTEGER, PRIVATE :: i DATA NROWS/ 31/ @@ -101,4 +101,4 @@ MODULE terms_C DATA (JTAB(I),I=30,32)/ 300, 303, 328/ DATA (NTAB(I),I=301,327)/ 1, 0, 16, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, & 2, 0, 17, 2, 0, 21, 2, 0, 25, 2, 0, 29/ - END MODULE terms_C + END MODULE terms_C diff --git a/src/lib/libmod/titl_C.f90 b/src/lib/libmod/titl_C.f90 index dae4c2327..cc10397f8 100644 --- a/src/lib/libmod/titl_C.f90 +++ b/src/lib/libmod/titl_C.f90 @@ -1,7 +1,7 @@ - MODULE titl_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer + MODULE titl_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: IHED, ITIME, IDATE - END MODULE titl_C + INTEGER :: IHED, ITIME, IDATE + END MODULE titl_C diff --git a/src/lib/libmod/vast_kind_param_M.f90 b/src/lib/libmod/vast_kind_param_M.f90 index b4756a2e0..561027e82 100644 --- a/src/lib/libmod/vast_kind_param_M.f90 +++ b/src/lib/libmod/vast_kind_param_M.f90 @@ -1,4 +1,4 @@ - module vast_kind_param + module vast_kind_param integer, parameter :: byte_log = selected_int_kind(2) integer, parameter :: short_log = selected_int_kind(4) integer, parameter :: long_log = selected_int_kind(18) @@ -10,4 +10,4 @@ module vast_kind_param integer, parameter :: double_ext = selected_real_kind(50) integer, parameter :: dble_complex = selected_real_kind(13) integer, parameter :: ext_complex = selected_real_kind(30) - end module vast_kind_param + end module vast_kind_param diff --git a/src/lib/libmod/vinlst_C.f90 b/src/lib/libmod/vinlst_C.f90 index 3ae98813e..faf86717a 100644 --- a/src/lib/libmod/vinlst_C.f90 +++ b/src/lib/libmod/vinlst_C.f90 @@ -1,10 +1,10 @@ - MODULE vinlst_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE vinlst_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NDVIN, NVINTI + INTEGER :: NDVIN, NVINTI INTEGER, DIMENSION(:), pointer :: indtei REAL(DOUBLE), DIMENSION(:), pointer :: valtei - LOGICAL :: FRSTVI - END MODULE vinlst_C + LOGICAL :: FRSTVI + END MODULE vinlst_C diff --git a/src/lib/libmod/vpilst_C.f90 b/src/lib/libmod/vpilst_C.f90 index 77a2c9829..45fca0ab9 100644 --- a/src/lib/libmod/vpilst_C.f90 +++ b/src/lib/libmod/vpilst_C.f90 @@ -1,10 +1,10 @@ - MODULE vpilst_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE vpilst_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: NDVPA, NVPI + INTEGER :: NDVPA, NVPI INTEGER, DIMENSION(:), pointer :: indvpi REAL(DOUBLE), DIMENSION(:), pointer :: valvpi - LOGICAL :: FRSTVP - END MODULE vpilst_C + LOGICAL :: FRSTVP + END MODULE vpilst_C diff --git a/src/lib/libmod/wave_C.f90 b/src/lib/libmod/wave_C.f90 index f2f327f4f..9e424a9fa 100644 --- a/src/lib/libmod/wave_C.f90 +++ b/src/lib/libmod/wave_C.f90 @@ -1,15 +1,15 @@ - MODULE wave_C - USE vast_kind_param, ONLY: DOUBLE + MODULE wave_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 07:38:02 1/ 6/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER, DIMENSION(NNNW) :: MF - REAL(DOUBLE), DIMENSION(NNNW) :: PZ - INTEGER, DIMENSION(NNNW) :: MFFF - REAL(DOUBLE), DIMENSION(NNNW) :: PZFF - INTEGER, DIMENSION(NNNW) :: MFII - REAL(DOUBLE), DIMENSION(NNNW) :: PZII + INTEGER, DIMENSION(NNNW) :: MF + REAL(DOUBLE), DIMENSION(NNNW) :: PZ + INTEGER, DIMENSION(NNNW) :: MFFF + REAL(DOUBLE), DIMENSION(NNNW) :: PZFF + INTEGER, DIMENSION(NNNW) :: MFII + REAL(DOUBLE), DIMENSION(NNNW) :: PZII REAL(DOUBLE), DIMENSION(:,:), pointer :: PF,QF REAL(DOUBLE), DIMENSION(:,:), pointer :: pfff,qfff,pfii,qfii END MODULE wave_C diff --git a/src/lib/libmod/wchblk_C.f90 b/src/lib/libmod/wchblk_C.f90 index 4b63ea10a..550c642ab 100644 --- a/src/lib/libmod/wchblk_C.f90 +++ b/src/lib/libmod/wchblk_C.f90 @@ -1,7 +1,7 @@ - MODULE wchblk_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 -!...Modified by Charlotte Froese Fischer + MODULE wchblk_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 14:07:38 1/ 5/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: JBLOCK - END MODULE wchblk_C + INTEGER :: JBLOCK + END MODULE wchblk_C diff --git a/src/lib/libmod/wfac_C.f90 b/src/lib/libmod/wfac_C.f90 index bb71b81b1..ea6adb6ca 100644 --- a/src/lib/libmod/wfac_C.f90 +++ b/src/lib/libmod/wfac_C.f90 @@ -1,7 +1,7 @@ - MODULE wfac_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE wfac_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - REAL(DOUBLE) :: WFACT - END MODULE wfac_C + REAL(DOUBLE) :: WFACT + END MODULE wfac_C diff --git a/src/lib/libmod/where_C.f90 b/src/lib/libmod/where_C.f90 index f5f63278c..413f869ae 100644 --- a/src/lib/libmod/where_C.f90 +++ b/src/lib/libmod/where_C.f90 @@ -1,7 +1,7 @@ - MODULE where_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE where_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:35:13 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - INTEGER :: IMCDF - END MODULE where_C + INTEGER :: IMCDF + END MODULE where_C diff --git a/src/lib/libmod/whfrom_C.f90 b/src/lib/libmod/whfrom_C.f90 index 35bce79a9..d6d553304 100644 --- a/src/lib/libmod/whfrom_C.f90 +++ b/src/lib/libmod/whfrom_C.f90 @@ -1,8 +1,8 @@ - MODULE whfrom_C - USE vast_kind_param, ONLY: DOUBLE + MODULE whfrom_C + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW -!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 -!...Modified by Charlotte Froese Fischer +!...Created by Pacific-Sierra Research 77to90 4.3E 11:02:52 1/ 2/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - CHARACTER, DIMENSION(NNNW) :: SOURCE*256 - END MODULE whfrom_C + CHARACTER, DIMENSION(NNNW) :: SOURCE*256 + END MODULE whfrom_C diff --git a/src/lib/librang90/Gracah1.f90 b/src/lib/librang90/Gracah1.f90 index 14e20ee88..7efcf1901 100644 --- a/src/lib/librang90/Gracah1.f90 +++ b/src/lib/librang90/Gracah1.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) + SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) ! * ! SUBROUTINE TO CALCULATE RACAH COEFFICIENTS. * ! THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE. * @@ -36,31 +36,31 @@ SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) !----------------------------------------------- INTEGER :: J1,J2,J3,J4,J5,J6,J7,NUMIN,NUMAX,ICOUNT,KK,KI !----------------------------------------------- - J1 = I+J+M - J2 = K+L+M - J3 = I+K+N - J4 = J+L+N + J1 = I+J+M + J2 = K+L+M + J3 = I+K+N + J4 = J+L+N IF (MOD(J1,2) == 0 .AND. MOD(J2,2) == 0 .AND. & - MOD(J3,2) == 0 .AND. MOD(J4,2) == 0 ) THEN - J1 = J1/2 - J2 = J2/2 - J3 = J3/2 - J4 = J4/2 + MOD(J3,2) == 0 .AND. MOD(J4,2) == 0 ) THEN + J1 = J1/2 + J2 = J2/2 + J3 = J3/2 + J4 = J4/2 IF (MAX(I,J,M) <= J1 .AND. MAX(K,L,M) <= J2 .AND. & - MAX(I,K,N) <= J3 .AND. MAX(J,L,N) <= J4 ) THEN - J5 = (I+J+K+L)/2 - J6 = (I+L+M+N)/2 - J7 = (J+K+M+N)/2 - NUMIN = MAX(J1, J2, J3, J4) + 1 - NUMAX = MIN(J5, J6, J7) + 1 - RAC = ONE - ICOUNT = 0 - DO KK = NUMIN+1,NUMAX - KI = NUMAX - ICOUNT + MAX(I,K,N) <= J3 .AND. MAX(J,L,N) <= J4 ) THEN + J5 = (I+J+K+L)/2 + J6 = (I+L+M+N)/2 + J7 = (J+K+M+N)/2 + NUMIN = MAX(J1, J2, J3, J4) + 1 + NUMAX = MIN(J5, J6, J7) + 1 + RAC = ONE + ICOUNT = 0 + DO KK = NUMIN+1,NUMAX + KI = NUMAX - ICOUNT RAC = ONE - (RAC*(KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)))/ & - ((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4)) - ICOUNT = ICOUNT+1 - END DO + ((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4)) + ICOUNT = ICOUNT+1 + END DO RAC = RAC*EXP( & (GAM(NUMIN+1) - GAM(NUMIN-J1) - GAM(NUMIN-J2) - & GAM(NUMIN-J3) - GAM(NUMIN-J4) - GAM(J5+2-NUMIN)- & @@ -73,8 +73,8 @@ SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) ELSE RAC = ZERO END IF - ELSE - RAC = ZERO - END IF - RETURN + ELSE + RAC = ZERO + END IF + RETURN END diff --git a/src/lib/librang90/Gracah1_I.f90 b/src/lib/librang90/Gracah1_I.f90 index 0720dc2a2..ec2d91299 100644 --- a/src/lib/librang90/Gracah1_I.f90 +++ b/src/lib/librang90/Gracah1_I.f90 @@ -1,7 +1,7 @@ MODULE gracah1_I INTERFACE ! - SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) + SUBROUTINE GRACAH1(I,J,K,L,M,N,RAC) USE vast_kind_param, ONLY: DOUBLE INTEGER MFACT PARAMETER (MFACT = 500) diff --git a/src/lib/librang90/Makefile b/src/lib/librang90/Makefile old mode 100755 new mode 100644 diff --git a/src/lib/librang90/ReadMe b/src/lib/librang90/ReadMe old mode 100755 new mode 100644 index cdcb28ba6..d811abc4b --- a/src/lib/librang90/ReadMe +++ b/src/lib/librang90/ReadMe @@ -1,6 +1,6 @@ Orginalioje programoje Grasp2K yra klaidu !!!! - * * * + * * * Panasiai kaip paprogrameje onescalar.f eilute @@ -11,15 +11,15 @@ Buvo keiciama i IF(JA .EQ. JB) THEN CALL ONESCALAR1(NS,JA,JB,JA1,JA2,TCOEFF) ELSE - TCOEFF = 0.0D 00 + TCOEFF = 0.0D 00 END IF Tai reiskia, kad kai viendalialinis skaliarinis operatorius i -veikia i i ta pati sluoksni, tai konfiguracijos turi buti tos +veikia i i ta pati sluoksni, tai konfiguracijos turi buti tos pacios. - * * * + * * * Panasiai, kaip paprogrameje rkco_gg.f ideti eilute @@ -30,9 +30,9 @@ CGG Negalima skaiciuoti kamieno ir kamieno ir valentiniu dvidalelinio fizikinio operatoriaus saveiku tarp skirtingu konfiguraciju. -Programa blogai skaiciuoja, +Programa blogai skaiciuoja, kai skaiciavimuose budavo tokios dvi ar daugiau konfiguracijos, -kuriose skirtumas susivesdavo tik i vyresniskumo kvantinio +kuriose skirtumas susivesdavo tik i vyresniskumo kvantinio skaiciaus verte. 2009.11.22 G.G. diff --git a/src/lib/librang90/Rmew3jj.f90 b/src/lib/librang90/Rmew3jj.f90 index c8a8a7f1e..a333aec0f 100644 --- a/src/lib/librang90/Rmew3jj.f90 +++ b/src/lib/librang90/Rmew3jj.f90 @@ -47,7 +47,7 @@ SUBROUTINE RMEW3JJ(J1,J2,K1,K2,COEF) IF(J1 == 3 .AND. J2 == 3) THEN COEF=DSQRT(DBLE(60)) ELSEIF(J1 == 5 .AND. J2 == 4) THEN - COEF=DSQRT(DBLE(30)) + COEF=DSQRT(DBLE(30)) ELSEIF(J1 == 4 .AND. J2 == 5) THEN COEF=-DSQRT(DBLE(30)) ENDIF diff --git a/src/lib/librang90/Rmew5jj.f90 b/src/lib/librang90/Rmew5jj.f90 index b89435bd5..4e5837fdf 100644 --- a/src/lib/librang90/Rmew5jj.f90 +++ b/src/lib/librang90/Rmew5jj.f90 @@ -55,7 +55,7 @@ SUBROUTINE RMEW5JJ(J1,J2,K1,K2,COEF) COEF=-DSQRT(DBLE(10)) ELSEIF(J1 == 11) THEN COEF=-DSQRT(DBLE(18)) - ENDIF + ENDIF ELSEIF(K1 == 0 .AND. K2 == 1) THEN IF(J1 /= J2) RETURN COEF=-DSQRT(DBLE(I01(J1-5))/DBLE(7)) diff --git a/src/lib/librang90/Rmew7bjj.f90 b/src/lib/librang90/Rmew7bjj.f90 index bdabaa061..177162c19 100644 --- a/src/lib/librang90/Rmew7bjj.f90 +++ b/src/lib/librang90/Rmew7bjj.f90 @@ -105,7 +105,7 @@ SUBROUTINE RMEW7BJJ(J1,J2,K1,K2,COEF) JI2=JI2-17 J=IPR2(JI1)+JI2 L=2 - ELSE + ELSE JI1=JI1-11 JI2=JI2-11 L=1 diff --git a/src/lib/librang90/awp1jjg.f90 b/src/lib/librang90/awp1jjg.f90 index ad22c3b9a..fecd1dceb 100644 --- a/src/lib/librang90/awp1jjg.f90 +++ b/src/lib/librang90/awp1jjg.f90 @@ -36,7 +36,7 @@ SUBROUTINE AWP1JJG(K1,BK2,QM1,QM2,QM3,IK,BK,ID,BD,AW) ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: KK1, KK2, IE, IQ, IQ2, IQ3, IQM, IT, ITP, ITG, IBTT - INTEGER, DIMENSION(7) :: IBT + INTEGER, DIMENSION(7) :: IBT REAL(DOUBLE) :: ENQP, D1, SI1, W REAL(DOUBLE), DIMENSION(3) :: BT !----------------------------------------------- diff --git a/src/lib/librang90/c1e0sm.f90 b/src/lib/librang90/c1e0sm.f90 index 1ba614353..4653f71c9 100644 --- a/src/lib/librang90/c1e0sm.f90 +++ b/src/lib/librang90/c1e0sm.f90 @@ -40,7 +40,7 @@ SUBROUTINE C1E0SM(Q,QM,C,CM,A) IIQ=TWO*Q+TENTH IIC=TWO*C+TENTH IF(ITTK(IIQ,IIC,2) == 0)RETURN - IF(DABS(QM-CM) > EPS) RETURN + IF(DABS(QM-CM) > EPS) RETURN IF((Q+TENTH) < DABS(QM)) RETURN IF((C+TENTH) < DABS(CM)) RETURN IF(DABS(QM) <= EPS) THEN diff --git a/src/lib/librang90/dracah.f90 b/src/lib/librang90/dracah.f90 index 8a75e45d0..bbd4b269a 100644 --- a/src/lib/librang90/dracah.f90 +++ b/src/lib/librang90/dracah.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE DRACAH(I, J, K, L, M, N, RAC) + SUBROUTINE DRACAH(I, J, K, L, M, N, RAC) ! * ! SUBROUTINE to calculate Racah coefficients. The arguments I, J, * ! K, L, M, N should be twice their actual value. Works for integer * @@ -12,72 +12,72 @@ SUBROUTINE DRACAH(I, J, K, L, M, N, RAC) ! The last modification made by G. Gaigalas October 2017 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 07:27:24 2/14/04 +!...Translated by Pacific-Sierra Research 77to90 4.3E 07:27:24 2/14/04 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE FACTS_C + USE vast_kind_param, ONLY: DOUBLE + USE FACTS_C IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER , INTENT(IN) :: I - INTEGER , INTENT(IN) :: J - INTEGER , INTENT(IN) :: K - INTEGER , INTENT(IN) :: L - INTEGER , INTENT(IN) :: M - INTEGER , INTENT(IN) :: N - REAL(DOUBLE) , INTENT(OUT) :: RAC + INTEGER , INTENT(IN) :: I + INTEGER , INTENT(IN) :: J + INTEGER , INTENT(IN) :: K + INTEGER , INTENT(IN) :: L + INTEGER , INTENT(IN) :: M + INTEGER , INTENT(IN) :: N + REAL(DOUBLE) , INTENT(OUT) :: RAC !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: J1, J2, J3, J4, J5, J6, J7, NUMIN, NUMAX, ICOUNT, KK, KI + INTEGER :: J1, J2, J3, J4, J5, J6, J7, NUMIN, NUMAX, ICOUNT, KK, KI !----------------------------------------------- - J1 = I + J + M - J2 = K + L + M - J3 = I + K + N - J4 = J + L + N - IF (2*MAX(MAX(I,J),M) - J1>0 .OR. MOD(J1,2)/=0) GO TO 2 - IF (2*MAX(MAX(K,L),M) - J2>0 .OR. MOD(J2,2)/=0) GO TO 2 - IF (2*MAX(MAX(I,K),N) - J3>0 .OR. MOD(J3,2)/=0) GO TO 2 - IF (2*MAX(MAX(J,L),N) - J4>0 .OR. MOD(J4,2)/=0) GO TO 2 - GO TO 1 - 2 CONTINUE - RAC = 0.0D00 - RETURN + J1 = I + J + M + J2 = K + L + M + J3 = I + K + N + J4 = J + L + N + IF (2*MAX(MAX(I,J),M) - J1>0 .OR. MOD(J1,2)/=0) GO TO 2 + IF (2*MAX(MAX(K,L),M) - J2>0 .OR. MOD(J2,2)/=0) GO TO 2 + IF (2*MAX(MAX(I,K),N) - J3>0 .OR. MOD(J3,2)/=0) GO TO 2 + IF (2*MAX(MAX(J,L),N) - J4>0 .OR. MOD(J4,2)/=0) GO TO 2 + GO TO 1 + 2 CONTINUE + RAC = 0.0D00 + RETURN ! - 1 CONTINUE - J1 = J1/2 - J2 = J2/2 - J3 = J3/2 - J4 = J4/2 - J5 = (I + J + K + L)/2 - J6 = (I + L + M + N)/2 - J7 = (J + K + M + N)/2 - NUMIN = MAX(MAX(MAX(J1,J2),J3),J4) + 1 - NUMAX = MIN(MIN(J5,J6),J7) + 1 - RAC = 1.0D00 - ICOUNT = 0 + 1 CONTINUE + J1 = J1/2 + J2 = J2/2 + J3 = J3/2 + J4 = J4/2 + J5 = (I + J + K + L)/2 + J6 = (I + L + M + N)/2 + J7 = (J + K + M + N)/2 + NUMIN = MAX(MAX(MAX(J1,J2),J3),J4) + 1 + NUMAX = MIN(MIN(J5,J6),J7) + 1 + RAC = 1.0D00 + ICOUNT = 0 ! - IF (NUMIN /= NUMAX) THEN - NUMIN = NUMIN + 1 + IF (NUMIN /= NUMAX) THEN + NUMIN = NUMIN + 1 ! - DO KK = NUMIN, NUMAX - KI = NUMAX - ICOUNT + DO KK = NUMIN, NUMAX + KI = NUMAX - ICOUNT RAC = 1.0D00 - RAC*DBLE(KI*(J5 - KI + 2)*(J6 - KI + 2)*(J7 - KI + 2& - ))/DBLE((KI - 1 - J1)*(KI - 1 - J2)*(KI - 1 - J3)*(KI - 1 - J4)) - ICOUNT = ICOUNT + 1 - END DO + ))/DBLE((KI - 1 - J1)*(KI - 1 - J2)*(KI - 1 - J3)*(KI - 1 - J4)) + ICOUNT = ICOUNT + 1 + END DO ! - NUMIN = NUMIN - 1 - ENDIF + NUMIN = NUMIN - 1 + ENDIF RAC = RAC*(-1.0D00)**(J5 + NUMIN + 1)*EXP((GAM(NUMIN+1)-GAM(NUMIN-J1)-GAM& (NUMIN-J2)-GAM(NUMIN-J3)-GAM(NUMIN-J4)-GAM(J5+2-NUMIN)-GAM(J6+2-NUMIN)& -GAM(J7+2-NUMIN))+(GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(J1+2)+GAM(& J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2)+GAM(J3+1-I)+GAM(J3+1-K)+GAM(& J3+1-N)-GAM(J3+2)+GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))*& - 0.5D00) + 0.5D00) ! - RETURN - END SUBROUTINE DRACAH + RETURN + END SUBROUTINE DRACAH diff --git a/src/lib/librang90/dracah_I.f90 b/src/lib/librang90/dracah_I.f90 index 97d344353..6e9df2eb4 100644 --- a/src/lib/librang90/dracah_I.f90 +++ b/src/lib/librang90/dracah_I.f90 @@ -1,18 +1,18 @@ - MODULE dracah_I + MODULE dracah_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 07:27:24 2/14/04 - SUBROUTINE dracah (I, J, K, L, M, N, RAC) - USE vast_kind_param, ONLY: DOUBLE - INTEGER MFACT - PARAMETER (MFACT = 500) - INTEGER, INTENT(IN) :: I - INTEGER, INTENT(IN) :: J - INTEGER, INTENT(IN) :: K - INTEGER, INTENT(IN) :: L - INTEGER, INTENT(IN) :: M - INTEGER, INTENT(IN) :: N - REAL(DOUBLE), INTENT(OUT) :: RAC +!...Generated by Pacific-Sierra Research 77to90 4.3E 07:27:24 2/14/04 + SUBROUTINE dracah (I, J, K, L, M, N, RAC) + USE vast_kind_param, ONLY: DOUBLE + INTEGER MFACT + PARAMETER (MFACT = 500) + INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: J + INTEGER, INTENT(IN) :: K + INTEGER, INTENT(IN) :: L + INTEGER, INTENT(IN) :: M + INTEGER, INTENT(IN) :: N + REAL(DOUBLE), INTENT(OUT) :: RAC !VAST.../FACTS/ GAM(IN) - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/librang90/eile.f90 b/src/lib/librang90/eile.f90 index bf14f70da..819667b90 100644 --- a/src/lib/librang90/eile.f90 +++ b/src/lib/librang90/eile.f90 @@ -16,7 +16,7 @@ SUBROUTINE EILE(JA,JB,JC,JAA,JBB,JCC) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JA, JB, JC + INTEGER, INTENT(IN) :: JA, JB, JC INTEGER, INTENT(OUT) :: JAA, JBB, JCC !----------------------------------------------- JAA=JA diff --git a/src/lib/librang90/eile_I.f90 b/src/lib/librang90/eile_I.f90 index 5a39aab06..d3dd29d26 100644 --- a/src/lib/librang90/eile_I.f90 +++ b/src/lib/librang90/eile_I.f90 @@ -2,7 +2,7 @@ MODULE eile_I INTERFACE ! * SUBROUTINE EILE(JA,JB,JC,JAA,JBB,JCC) - INTEGER, INTENT(IN) :: JA, JB, JC + INTEGER, INTENT(IN) :: JA, JB, JC INTEGER, INTENT(OUT) :: JAA, JBB, JCC END SUBROUTINE END INTERFACE diff --git a/src/lib/librang90/el1.f90 b/src/lib/librang90/el1.f90 index 4d1fab00a..39fb09c49 100644 --- a/src/lib/librang90/el1.f90 +++ b/src/lib/librang90/el1.f90 @@ -46,13 +46,13 @@ SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI + INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI ! DIMENSION CONE(7,20),S(12),IS(4),KAPS(4),KS(4) ! DIMENSION PMGG(30),RAGG(30),J(2) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: II,IA,IB,IAT,IP1,IP2,IP3,IG1,IG2,IG3,IKK,I1,I2,I3,I4,& + INTEGER :: II,IA,IB,IAT,IP1,IP2,IP3,IG1,IG2,IG3,IKK,I1,I2,I3,I4,& IFAZ,J12,IBRD,IBRE,KRA,KRA1,L1,L2,MU,N,NU,ND1,ND2, & NE1,NE2,NUP1 INTEGER, DIMENSION(2) :: J @@ -60,7 +60,7 @@ SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) REAL(DOUBLE) :: QM1,QM2,QM3,QM4,AA,AB,A1,BB,SI,RECC,RAG REAL(DOUBLE), DIMENSION(12) :: S REAL(DOUBLE), DIMENSION(30) :: PMGG,RAGG - REAL(DOUBLE), DIMENSION(7,20) :: CONE + REAL(DOUBLE), DIMENSION(7,20) :: CONE !----------------------------------------------- IF(JA /= JB)GO TO 9 ! @@ -99,7 +99,7 @@ SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) KS(3)=IABS(KAPS(3)) KS(4)=IABS(KAPS(4)) CALL SNRC(IS,KAPS,KS,ND1,ND2,NE1,NE2,IBRD,IBRE) - IF(IBRD <= 0)RETURN + IF(IBRD <= 0)RETURN END IF DO I2=IP1,IG1,2 KRA=(I2-1)/2 @@ -202,7 +202,7 @@ SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) CONE(6,II)=ZERO CONE(7,II)=ZERO END DO - IF(IBRD == 0 .AND. IBRE == 0)RETURN + IF(IBRD == 0 .AND. IBRE == 0)RETURN END IF DO I1=IP1,IG1,2 KRA=(I1-1)/2 @@ -260,7 +260,7 @@ SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) BB=A1*AB IF(DABS(BB) > EPS)CALL SPEAK(JJA,JJB,IA,IB,IB,IA,KRA,BB) ELSE IF (ICOLBREI == 2) THEN - NU=KRA + NU=KRA IF(((NU-NE1)/2)*2 == (NU-NE1)) THEN IF((ITRIG(KS(1),KS(4),NU+NU+1) /= 0) .AND. & (ITRIG(KS(2),KS(3),NU+NU+1) /= 0)) THEN diff --git a/src/lib/librang90/el1_I.f90 b/src/lib/librang90/el1_I.f90 index 4a2d8ecb1..e42e83327 100644 --- a/src/lib/librang90/el1_I.f90 +++ b/src/lib/librang90/el1_I.f90 @@ -2,7 +2,7 @@ MODULE el1_I INTERFACE ! SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI) - INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI + INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI END SUBROUTINE END INTERFACE END MODULE diff --git a/src/lib/librang90/itrexg.f90 b/src/lib/librang90/itrexg.f90 index 42509fb64..a978e65dc 100644 --- a/src/lib/librang90/itrexg.f90 +++ b/src/lib/librang90/itrexg.f90 @@ -2,7 +2,7 @@ ! * INTEGER FUNCTION ITREXG(I1,I2,I3,I4,K) ! -! Written by G. Gaigalas, * +! Written by G. Gaigalas, * ! Vanderbilt University, Nashville October 1996 * ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! The last modification made by G. Gaigalas October 2017 * diff --git a/src/lib/librang90/ittk.f90 b/src/lib/librang90/ittk.f90 index 2052f4e11..986e43985 100644 --- a/src/lib/librang90/ittk.f90 +++ b/src/lib/librang90/ittk.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - INTEGER FUNCTION ITTK (I, J, K) + INTEGER FUNCTION ITTK (I, J, K) ! * ! CHESKED TRIANGULAR CONDITIONS FOR I/2, J/2, K/2. * ! I+J>=K, I+K>=J, J+K>=I, * @@ -14,17 +14,17 @@ INTEGER FUNCTION ITTK (I, J, K) ! The last modification made by G. Gaigalas October 2017 * ! * !******************************************************************* -! +! IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER, INTENT(IN) :: I, J, K !----------------------------------------------- - ITTK = 0 - IF (IABS(I - J) > K) RETURN - IF (I + J < K) RETURN - IF (MOD(I + J + K,2) /= 0) RETURN - ITTK = 1 - RETURN - END FUNCTION ITTK + ITTK = 0 + IF (IABS(I - J) > K) RETURN + IF (I + J < K) RETURN + IF (MOD(I + J + K,2) /= 0) RETURN + ITTK = 1 + RETURN + END FUNCTION ITTK diff --git a/src/lib/librang90/ittk_I.f90 b/src/lib/librang90/ittk_I.f90 index 167a081fb..e8b2be95c 100644 --- a/src/lib/librang90/ittk_I.f90 +++ b/src/lib/librang90/ittk_I.f90 @@ -1,6 +1,6 @@ MODULE ittk_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 09:56:17 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 09:56:17 11/16/01 INTEGER FUNCTION ittk (I, J, K) INTEGER, INTENT(IN) :: I INTEGER, INTENT(IN) :: J diff --git a/src/lib/librang90/ixjtik.f90 b/src/lib/librang90/ixjtik.f90 index aaadf93ee..66aea1baa 100644 --- a/src/lib/librang90/ixjtik.f90 +++ b/src/lib/librang90/ixjtik.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - INTEGER FUNCTION IXJTIK (I, J, K, L, M, N) + INTEGER FUNCTION IXJTIK (I, J, K, L, M, N) ! * ! CHESKED TRIANGULAR CONDITIONS FOR 6j COEFFICIENT * ! * @@ -17,18 +17,18 @@ INTEGER FUNCTION IXJTIK (I, J, K, L, M, N) !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ittk_I + USE ittk_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: I, J, K, L, M, N !----------------------------------------------- - IXJTIK = 0 - IF (ITTK(I,J,K) == 0) RETURN - IF (ITTK(I,M,N) == 0) RETURN - IF (ITTK(L,J,N) == 0) RETURN - IF (ITTK(L,M,K) == 0) RETURN - IXJTIK = 1 - RETURN - END FUNCTION IXJTIK + IXJTIK = 0 + IF (ITTK(I,J,K) == 0) RETURN + IF (ITTK(I,M,N) == 0) RETURN + IF (ITTK(L,J,N) == 0) RETURN + IF (ITTK(L,M,K) == 0) RETURN + IXJTIK = 1 + RETURN + END FUNCTION IXJTIK diff --git a/src/lib/librang90/ixjtik_I.f90 b/src/lib/librang90/ixjtik_I.f90 index 592031cdd..4900b1f51 100644 --- a/src/lib/librang90/ixjtik_I.f90 +++ b/src/lib/librang90/ixjtik_I.f90 @@ -1,6 +1,6 @@ MODULE ixjtik_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:05:49 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:05:49 11/16/01 INTEGER FUNCTION ixjtik (I, J, K, L, M, N) INTEGER :: I INTEGER :: J diff --git a/src/lib/librang90/jthn.f90 b/src/lib/librang90/jthn.f90 index e4795b329..1990691e0 100644 --- a/src/lib/librang90/jthn.f90 +++ b/src/lib/librang90/jthn.f90 @@ -2,12 +2,12 @@ ! * INTEGER FUNCTION JTHN(K,N,I) ! * -! Written by G. Gaigalas, * +! Written by G. Gaigalas, * ! Vanderbilt University, Nashville October 1996 * ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! The last modification made by G. Gaigalas October 2017 * ! * -!******************************************************************* +!******************************************************************* ! !----------------------------------------------- ! D u m m y A r g u m e n t s diff --git a/src/lib/librang90/mes.f90 b/src/lib/librang90/mes.f90 index 7146a2618..7dbec52f7 100644 --- a/src/lib/librang90/mes.f90 +++ b/src/lib/librang90/mes.f90 @@ -25,7 +25,7 @@ SUBROUTINE MES(I) !----------------------------------------------- IF(I > 50) THEN J=I-50 - WRITE(6,'(A)') ' error in func./sub. ' + WRITE(6,'(A)') ' error in func./sub. ' WRITE(6,'(20X,A10)') STRING5(J) WRITE(6,'(A)') ' susimaise f sluoksnio termu kodavimas ' ELSE diff --git a/src/lib/librang90/nine.f90 b/src/lib/librang90/nine.f90 index 7e5ae5109..0061219f3 100644 --- a/src/lib/librang90/nine.f90 +++ b/src/lib/librang90/nine.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,INN,AA) + SUBROUTINE NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,INN,AA) ! ! * ! THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT * @@ -17,69 +17,69 @@ SUBROUTINE NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,INN,AA) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ittk_I - USE nine0_I - USE sixj_I + USE ittk_I + USE nine0_I + USE sixj_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J1, J2, J3, L1, L2, L3, K1, K2, K3 - INTEGER, INTENT(IN) :: I + INTEGER, INTENT(IN) :: I INTEGER, INTENT(OUT) :: INN - REAL(DOUBLE) :: AA + REAL(DOUBLE) :: AA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: N1, N2, N3, N4, N5, N6, MAX_, MIN_, IX - REAL(DOUBLE) :: S1, S2, S3, X + INTEGER :: N1, N2, N3, N4, N5, N6, MAX_, MIN_, IX + REAL(DOUBLE) :: S1, S2, S3, X !----------------------------------------------- - IF (I == 1) THEN - INN = 0 - IF (ITTK(J1,J2,J3) == 0) RETURN - IF (ITTK(L1,L2,L3) == 0) RETURN - IF (ITTK(K1,K2,K3) == 0) RETURN - IF (ITTK(J1,L1,K1) == 0) RETURN - IF (ITTK(J2,L2,K2) == 0) RETURN - IF (ITTK(J3,L3,K3) == 0) RETURN - INN = 1 - RETURN - ENDIF - IF (J1*J2*J3*L1*L2*L3*K1*K2*K3 == 0) THEN - INN = 1 - CALL NINE0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, AA) - ELSE - N1 = IABS(J1 - K3) - N2 = IABS(L3 - J2) - N3 = IABS(L1 - K2) - N4 = IABS(J2 - L3) - N5 = IABS(K2 - L1) - N6 = IABS(J1 - K3) - MAX_ = MAX0(N1,N2,N3,N4,N5,N6) - N1 = J1 + K3 - N2 = L3 + J2 - N3 = J2 + L3 - N4 = K2 + L1 - N5 = J1 + K3 - N6 = L1 + K2 - MIN_ = MIN0(N1,N2,N3,N4,N5,N6) - INN = 1 - AA = ZERO - DO IX = MAX_, MIN_, 2 - CALL SIXJ (J1, J2, J3, L3, K3, IX, 0, S1) - CALL SIXJ (L1, L2, L3, J2, IX, K2, 0, S2) - CALL SIXJ (K1, K2, K3, IX, J1, L1, 0, S3) - X = S1*S2*S3*DBLE(IX + 1) - IF (MOD(IX,2) /= 0) X = -X - AA = X + AA - END DO - ENDIF - RETURN - END SUBROUTINE NINE + IF (I == 1) THEN + INN = 0 + IF (ITTK(J1,J2,J3) == 0) RETURN + IF (ITTK(L1,L2,L3) == 0) RETURN + IF (ITTK(K1,K2,K3) == 0) RETURN + IF (ITTK(J1,L1,K1) == 0) RETURN + IF (ITTK(J2,L2,K2) == 0) RETURN + IF (ITTK(J3,L3,K3) == 0) RETURN + INN = 1 + RETURN + ENDIF + IF (J1*J2*J3*L1*L2*L3*K1*K2*K3 == 0) THEN + INN = 1 + CALL NINE0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, AA) + ELSE + N1 = IABS(J1 - K3) + N2 = IABS(L3 - J2) + N3 = IABS(L1 - K2) + N4 = IABS(J2 - L3) + N5 = IABS(K2 - L1) + N6 = IABS(J1 - K3) + MAX_ = MAX0(N1,N2,N3,N4,N5,N6) + N1 = J1 + K3 + N2 = L3 + J2 + N3 = J2 + L3 + N4 = K2 + L1 + N5 = J1 + K3 + N6 = L1 + K2 + MIN_ = MIN0(N1,N2,N3,N4,N5,N6) + INN = 1 + AA = ZERO + DO IX = MAX_, MIN_, 2 + CALL SIXJ (J1, J2, J3, L3, K3, IX, 0, S1) + CALL SIXJ (L1, L2, L3, J2, IX, K2, 0, S2) + CALL SIXJ (K1, K2, K3, IX, J1, L1, 0, S3) + X = S1*S2*S3*DBLE(IX + 1) + IF (MOD(IX,2) /= 0) X = -X + AA = X + AA + END DO + ENDIF + RETURN + END SUBROUTINE NINE diff --git a/src/lib/librang90/nine0.f90 b/src/lib/librang90/nine0.f90 index 14e3e7898..758ef3070 100644 --- a/src/lib/librang90/nine0.f90 +++ b/src/lib/librang90/nine0.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,AA) + SUBROUTINE NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,AA) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT * ! * @@ -16,67 +16,67 @@ SUBROUTINE NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,AA) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE sixj_I + USE sixj_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J1, J2, J3, L1, L2, L3, K1, K2, K3 - REAL(DOUBLE), INTENT(OUT) :: AA + REAL(DOUBLE), INTENT(OUT) :: AA !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IFA - REAL(DOUBLE) :: A, B + INTEGER :: IFA + REAL(DOUBLE) :: A, B !----------------------------------------------- - IF (J1 == 0) THEN - CALL SIXJ (L2, K2, J2, K3, L3, L1, 0, A) - B = DBLE((J2 + 1)*(L1 + 1)) - IFA = K2 + J2 + L3 + L1 - ELSE IF (J2 == 0) THEN - CALL SIXJ (L3, K3, J3, K1, L1, L2, 0, A) - B = DBLE((J3 + 1)*(L2 + 1)) - IFA = K3 + J3 + L1 + L2 - ELSE IF (J3 == 0) THEN - CALL SIXJ (L1, K1, J1, K2, L2, L3, 0, A) - B = DBLE((J1 + 1)*(L3 + 1)) - IFA = K1 + J1 + L2 + L3 - ELSE IF (L1 == 0) THEN - CALL SIXJ (K2, J2, L2, J3, K3, K1, 0, A) - B = DBLE((L2 + 1)*(K1 + 1)) - IFA = J2 + L2 + K3 + K1 - ELSE IF (L2 == 0) THEN - CALL SIXJ (K3, J3, L3, J1, K1, K2, 0, A) - B = DBLE((L3 + 1)*(K2 + 1)) - IFA = J3 + L3 + K1 + K2 - ELSE IF (L3 == 0) THEN - CALL SIXJ (K1, J1, L1, J2, K2, K3, 0, A) - B = DBLE((L1 + 1)*(K3 + 1)) - IFA = J1 + L1 + K2 + K3 - ELSE IF (K1 == 0) THEN - CALL SIXJ (J2, J3, J1, L3, L2, K2, 0, A) - B = DBLE((J1 + 1)*(K2 + 1)) - IFA = J3 + J1 + L2 + K2 - ELSE IF (K2 == 0) THEN - CALL SIXJ (J3, J1, J2, L1, L3, K3, 0, A) - B = DBLE((J2 + 1)*(K3 + 1)) - IFA = J1 + J2 + L3 + K3 - ELSE IF (K3 == 0) THEN - CALL SIXJ (J1, J2, J3, L2, L1, K1, 0, A) - B = DBLE((J3 + 1)*(K1 + 1)) - IFA = J2 + J3 + L1 + K1 - ELSE - A = ZERO - B = ONE - ENDIF - AA = A/DSQRT(B) - IF (MOD(IFA,4) /= 0) AA = -AA - RETURN - END SUBROUTINE NINE0 + IF (J1 == 0) THEN + CALL SIXJ (L2, K2, J2, K3, L3, L1, 0, A) + B = DBLE((J2 + 1)*(L1 + 1)) + IFA = K2 + J2 + L3 + L1 + ELSE IF (J2 == 0) THEN + CALL SIXJ (L3, K3, J3, K1, L1, L2, 0, A) + B = DBLE((J3 + 1)*(L2 + 1)) + IFA = K3 + J3 + L1 + L2 + ELSE IF (J3 == 0) THEN + CALL SIXJ (L1, K1, J1, K2, L2, L3, 0, A) + B = DBLE((J1 + 1)*(L3 + 1)) + IFA = K1 + J1 + L2 + L3 + ELSE IF (L1 == 0) THEN + CALL SIXJ (K2, J2, L2, J3, K3, K1, 0, A) + B = DBLE((L2 + 1)*(K1 + 1)) + IFA = J2 + L2 + K3 + K1 + ELSE IF (L2 == 0) THEN + CALL SIXJ (K3, J3, L3, J1, K1, K2, 0, A) + B = DBLE((L3 + 1)*(K2 + 1)) + IFA = J3 + L3 + K1 + K2 + ELSE IF (L3 == 0) THEN + CALL SIXJ (K1, J1, L1, J2, K2, K3, 0, A) + B = DBLE((L1 + 1)*(K3 + 1)) + IFA = J1 + L1 + K2 + K3 + ELSE IF (K1 == 0) THEN + CALL SIXJ (J2, J3, J1, L3, L2, K2, 0, A) + B = DBLE((J1 + 1)*(K2 + 1)) + IFA = J3 + J1 + L2 + K2 + ELSE IF (K2 == 0) THEN + CALL SIXJ (J3, J1, J2, L1, L3, K3, 0, A) + B = DBLE((J2 + 1)*(K3 + 1)) + IFA = J1 + J2 + L3 + K3 + ELSE IF (K3 == 0) THEN + CALL SIXJ (J1, J2, J3, L2, L1, K1, 0, A) + B = DBLE((J3 + 1)*(K1 + 1)) + IFA = J2 + J3 + L1 + K1 + ELSE + A = ZERO + B = ONE + ENDIF + AA = A/DSQRT(B) + IF (MOD(IFA,4) /= 0) AA = -AA + RETURN + END SUBROUTINE NINE0 diff --git a/src/lib/librang90/nine0_I.f90 b/src/lib/librang90/nine0_I.f90 index ddbc0b9b0..002547c01 100644 --- a/src/lib/librang90/nine0_I.f90 +++ b/src/lib/librang90/nine0_I.f90 @@ -1,6 +1,6 @@ MODULE nine0_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:07:58 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:07:58 11/16/01 SUBROUTINE nine0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, AA) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J1 diff --git a/src/lib/librang90/nine_I.f90 b/src/lib/librang90/nine_I.f90 index 849c1d4c5..97be9e83a 100644 --- a/src/lib/librang90/nine_I.f90 +++ b/src/lib/librang90/nine_I.f90 @@ -1,6 +1,6 @@ MODULE nine_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:07:58 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:07:58 11/16/01 SUBROUTINE nine (J1, J2, J3, L1, L2, L3, K1, K2, K3, I, IN, AA) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J1 diff --git a/src/lib/librang90/oneparticlejj.f90 b/src/lib/librang90/oneparticlejj.f90 index 8e88bddf4..4b0ca31a6 100644 --- a/src/lib/librang90/oneparticlejj.f90 +++ b/src/lib/librang90/oneparticlejj.f90 @@ -175,16 +175,16 @@ SUBROUTINE ONEPARTICLEJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL) CALL ONEPARTICLEJJ1(NS,KA,JA,JB,JA1,JA2,TCOEFF) !GG CALL ONESCALAR1(NS,JA,JB,JA1,JA2,TCOEFF) !GG ELSE -!GG TCOEFF = 0.0D 00 +!GG TCOEFF = 0.0D 00 !GG END IF - ELSE IF (IDQ .EQ. 2) THEN + ELSE IF (IDQ .EQ. 2) THEN ! ! IDQ = 2 Case ! ! Permutation factor for IDQ = 2 CALL ONEPARTICLEJJ2(NS,KA,JA1,JA2,TCOEFF) !GG CALL ONESCALAR2(JA,JB,JA1,JA2,TCOEFF) - VSHELL(1) = TCOEFF + VSHELL(1) = TCOEFF RETURN END IF ! diff --git a/src/lib/librang90/onescalar.f90 b/src/lib/librang90/onescalar.f90 index b05bbc0d3..f38f257b3 100644 --- a/src/lib/librang90/onescalar.f90 +++ b/src/lib/librang90/onescalar.f90 @@ -180,13 +180,13 @@ SUBROUTINE ONESCALAR(JA,JB,IA1,IA2,VSHELL) ELSE TCOEFF = ZERO END IF - ELSE IF (IDQ .EQ. 2) THEN + ELSE IF (IDQ .EQ. 2) THEN ! ! IDQ = 2 Case ! ! Permutation factor for IDQ = 2 CALL ONESCALAR2(JA,JB,JA1,JA2,TCOEFF) - VSHELL(1) = TCOEFF + VSHELL(1) = TCOEFF RETURN END IF ! diff --git a/src/lib/librang90/recop00.f90 b/src/lib/librang90/recop00.f90 index d88074059..b2c43d58c 100644 --- a/src/lib/librang90/recop00.f90 +++ b/src/lib/librang90/recop00.f90 @@ -62,7 +62,7 @@ SUBROUTINE RECOP00(NS,JA1,JA2,KA,IAT) ENDIF END DO IF(IAT == 0)RETURN - IF(NPEELGG <= 2)RETURN + IF(NPEELGG <= 2)RETURN IF(JA1 <= 2)RETURN DO J=3,JA1 JJ=J-2 diff --git a/src/lib/librang90/sixj.f90 b/src/lib/librang90/sixj.f90 index ba2e1d168..ba64d2024 100644 --- a/src/lib/librang90/sixj.f90 +++ b/src/lib/librang90/sixj.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ(I,J,K,L,M,N,ITIK,SI) + SUBROUTINE SIXJ(I,J,K,L,M,N,ITIK,SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -15,209 +15,209 @@ SUBROUTINE SIXJ(I,J,K,L,M,N,ITIK,SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I - USE sixj5_I - USE sixj1_I - USE sixj35_I - USE sixj2_I -! USE gracah1_I - USE dracah_I - USE sixj3_I - USE sixj4_I + USE ixjtik_I + USE sixj5_I + USE sixj1_I + USE sixj35_I + USE sixj2_I +! USE gracah1_I + USE dracah_I + USE sixj3_I + USE sixj4_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: I, J, K, L, M, N - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IFA - REAL(DOUBLE), DIMENSION(0:4,0:4,0:4,0:4,0:4,0:4) :: RACA - REAL(DOUBLE) :: UNDEF, A - LOGICAL :: SAVE + INTEGER :: IFA + REAL(DOUBLE), DIMENSION(0:4,0:4,0:4,0:4,0:4,0:4) :: RACA + REAL(DOUBLE) :: UNDEF, A + LOGICAL :: SAVE !----------------------------------------------- - DATA RACA/ 15625*1.D-20/ - DATA UNDEF/ 1.D-20/ - SI = ZERO - IF (ITIK /= 0) THEN + DATA RACA/ 15625*1.D-20/ + DATA UNDEF/ 1.D-20/ + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(I,J,K,L,M,N) == 0) RETURN - ENDIF - SAVE = .FALSE. - IF (MAX0(I,J,K,L,M,N) <= 4) THEN - SI = RACA(I,J,K,L,M,N) - IF (SI == UNDEF) THEN - SAVE = .TRUE. - ELSE - RETURN - ENDIF - ENDIF + IF (IXJTIK(I,J,K,L,M,N) == 0) RETURN + ENDIF + SAVE = .FALSE. + IF (MAX0(I,J,K,L,M,N) <= 4) THEN + SI = RACA(I,J,K,L,M,N) + IF (SI == UNDEF) THEN + SAVE = .TRUE. + ELSE + RETURN + ENDIF + ENDIF ! ! CALCULATED IN CASE WHEN ONE OF PERAMETERS EQUAL 0 ! - IF (I*J*K*L*M*N == 0) THEN - IF (I == 0) THEN - A = DBLE((M + 1)*(K + 1)) - IFA = L + M + K - ELSE IF (J == 0) THEN - A = DBLE((L + 1)*(K + 1)) - IFA = I + M + N - ELSE IF (K == 0) THEN - A = DBLE((I + 1)*(L + 1)) - IFA = I + M + N - ELSE IF (L == 0) THEN - A = DBLE((J + 1)*(K + 1)) - IFA = I + J + K - ELSE IF (M == 0) THEN - A = DBLE((I + 1)*(K + 1)) - IFA = I + J + K - ELSE - A = DBLE((I + 1)*(J + 1)) - IFA = I + J + K - ENDIF - SI = ONE/DSQRT(A) - IF (MOD(IFA,4) /= 0) SI = -SI + IF (I*J*K*L*M*N == 0) THEN + IF (I == 0) THEN + A = DBLE((M + 1)*(K + 1)) + IFA = L + M + K + ELSE IF (J == 0) THEN + A = DBLE((L + 1)*(K + 1)) + IFA = I + M + N + ELSE IF (K == 0) THEN + A = DBLE((I + 1)*(L + 1)) + IFA = I + M + N + ELSE IF (L == 0) THEN + A = DBLE((J + 1)*(K + 1)) + IFA = I + J + K + ELSE IF (M == 0) THEN + A = DBLE((I + 1)*(K + 1)) + IFA = I + J + K + ELSE + A = DBLE((I + 1)*(J + 1)) + IFA = I + J + K + ENDIF + SI = ONE/DSQRT(A) + IF (MOD(IFA,4) /= 0) SI = -SI ! ! THE CASE 1/2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 1) THEN - IF (I == 1) THEN - CALL SIXJ5 (M, K, L, J, N, 0, SI) - ELSE IF (J == 1) THEN - CALL SIXJ5 (I, N, M, L, K, 0, SI) - ELSE IF (K == 1) THEN - CALL SIXJ5 (I, M, N, L, J, 0, SI) - ELSE IF (L == 1) THEN - CALL SIXJ5 (J, K, I, M, N, 0, SI) - ELSE IF (M == 1) THEN - CALL SIXJ5 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ5 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 1) THEN + IF (I == 1) THEN + CALL SIXJ5 (M, K, L, J, N, 0, SI) + ELSE IF (J == 1) THEN + CALL SIXJ5 (I, N, M, L, K, 0, SI) + ELSE IF (K == 1) THEN + CALL SIXJ5 (I, M, N, L, J, 0, SI) + ELSE IF (L == 1) THEN + CALL SIXJ5 (J, K, I, M, N, 0, SI) + ELSE IF (M == 1) THEN + CALL SIXJ5 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ5 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 1 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 2) THEN - IF (I == 2) THEN - CALL SIXJ1 (M, K, L, J, N, 0, SI) - ELSE IF (J == 2) THEN - CALL SIXJ1 (I, N, M, L, K, 0, SI) - ELSE IF (K == 2) THEN - CALL SIXJ1 (I, M, N, L, J, 0, SI) - ELSE IF (L == 2) THEN - CALL SIXJ1 (J, K, I, M, N, 0, SI) - ELSE IF (M == 2) THEN - CALL SIXJ1 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ1 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 2) THEN + IF (I == 2) THEN + CALL SIXJ1 (M, K, L, J, N, 0, SI) + ELSE IF (J == 2) THEN + CALL SIXJ1 (I, N, M, L, K, 0, SI) + ELSE IF (K == 2) THEN + CALL SIXJ1 (I, M, N, L, J, 0, SI) + ELSE IF (L == 2) THEN + CALL SIXJ1 (J, K, I, M, N, 0, SI) + ELSE IF (M == 2) THEN + CALL SIXJ1 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ1 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 3/2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 3) THEN - IF (I == 3) THEN - CALL SIXJ35 (M, K, L, J, N, 0, SI) - ELSE IF (J == 3) THEN - CALL SIXJ35 (I, N, M, L, K, 0, SI) - ELSE IF (K == 3) THEN - CALL SIXJ35 (I, M, N, L, J, 0, SI) - ELSE IF (L == 3) THEN - CALL SIXJ35 (J, K, I, M, N, 0, SI) - ELSE IF (M == 3) THEN - CALL SIXJ35 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ35 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 3) THEN + IF (I == 3) THEN + CALL SIXJ35 (M, K, L, J, N, 0, SI) + ELSE IF (J == 3) THEN + CALL SIXJ35 (I, N, M, L, K, 0, SI) + ELSE IF (K == 3) THEN + CALL SIXJ35 (I, M, N, L, J, 0, SI) + ELSE IF (L == 3) THEN + CALL SIXJ35 (J, K, I, M, N, 0, SI) + ELSE IF (M == 3) THEN + CALL SIXJ35 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ35 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 4) THEN - IF (I == 4) THEN - CALL SIXJ2 (M, K, L, J, N, 0, SI) - ELSE IF (J == 4) THEN - CALL SIXJ2 (I, N, M, L, K, 0, SI) - ELSE IF (K == 4) THEN - CALL SIXJ2 (I, M, N, L, J, 0, SI) - ELSE IF (L == 4) THEN - CALL SIXJ2 (J, K, I, M, N, 0, SI) - ELSE IF (M == 4) THEN - CALL SIXJ2 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ2 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 4) THEN + IF (I == 4) THEN + CALL SIXJ2 (M, K, L, J, N, 0, SI) + ELSE IF (J == 4) THEN + CALL SIXJ2 (I, N, M, L, K, 0, SI) + ELSE IF (K == 4) THEN + CALL SIXJ2 (I, M, N, L, J, 0, SI) + ELSE IF (L == 4) THEN + CALL SIXJ2 (J, K, I, M, N, 0, SI) + ELSE IF (M == 4) THEN + CALL SIXJ2 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ2 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 5/2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 5) THEN - CALL DRACAH (I, J, M, L, K, N, SI) - IF (MOD(I + J + M + L,4) /= 0) SI = -SI + ELSE IF (MIN0(I,J,K,L,M,N) == 5) THEN + CALL DRACAH (I, J, M, L, K, N, SI) + IF (MOD(I + J + M + L,4) /= 0) SI = -SI ! ! CASES 3 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 6) THEN - IF (I == 6) THEN - CALL SIXJ3 (M, K, L, J, N, 0, SI) - ELSE IF (J == 6) THEN - CALL SIXJ3 (I, N, M, L, K, 0, SI) - ELSE IF (K == 6) THEN - CALL SIXJ3 (I, M, N, L, J, 0, SI) - ELSE IF (L == 6) THEN - CALL SIXJ3 (J, K, I, M, N, 0, SI) - ELSE IF (M == 6) THEN - CALL SIXJ3 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ3 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 6) THEN + IF (I == 6) THEN + CALL SIXJ3 (M, K, L, J, N, 0, SI) + ELSE IF (J == 6) THEN + CALL SIXJ3 (I, N, M, L, K, 0, SI) + ELSE IF (K == 6) THEN + CALL SIXJ3 (I, M, N, L, J, 0, SI) + ELSE IF (L == 6) THEN + CALL SIXJ3 (J, K, I, M, N, 0, SI) + ELSE IF (M == 6) THEN + CALL SIXJ3 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ3 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 7/2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 7) THEN - CALL DRACAH (I, J, M, L, K, N, SI) - IF (MOD(I + J + M + L,4) /= 0) SI = -SI + ELSE IF (MIN0(I,J,K,L,M,N) == 7) THEN + CALL DRACAH (I, J, M, L, K, N, SI) + IF (MOD(I + J + M + L,4) /= 0) SI = -SI ! ! CASES 4 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 8) THEN - IF (I == 8) THEN - CALL SIXJ4 (M, K, L, J, N, 0, SI) - ELSE IF (J == 8) THEN - CALL SIXJ4 (I, N, M, L, K, 0, SI) - ELSE IF (K == 8) THEN - CALL SIXJ4 (I, M, N, L, J, 0, SI) - ELSE IF (L == 8) THEN - CALL SIXJ4 (J, K, I, M, N, 0, SI) - ELSE IF (M == 8) THEN - CALL SIXJ4 (I, K, J, L, N, 0, SI) - ELSE - CALL SIXJ4 (I, J, K, L, M, 0, SI) - ENDIF + ELSE IF (MIN0(I,J,K,L,M,N) == 8) THEN + IF (I == 8) THEN + CALL SIXJ4 (M, K, L, J, N, 0, SI) + ELSE IF (J == 8) THEN + CALL SIXJ4 (I, N, M, L, K, 0, SI) + ELSE IF (K == 8) THEN + CALL SIXJ4 (I, M, N, L, J, 0, SI) + ELSE IF (L == 8) THEN + CALL SIXJ4 (J, K, I, M, N, 0, SI) + ELSE IF (M == 8) THEN + CALL SIXJ4 (I, K, J, L, N, 0, SI) + ELSE + CALL SIXJ4 (I, J, K, L, M, 0, SI) + ENDIF ! ! THE CASE 9/2 ! - ELSE IF (MIN0(I,J,K,L,M,N) == 9) THEN - CALL DRACAH (I, J, M, L, K, N, SI) - IF (MOD(I + J + M + L,4) /= 0) SI = -SI + ELSE IF (MIN0(I,J,K,L,M,N) == 9) THEN + CALL DRACAH (I, J, M, L, K, N, SI) + IF (MOD(I + J + M + L,4) /= 0) SI = -SI ! ! CALCULATED OTHER CASES ! - ELSE + ELSE CALL DRACAH(I,J,M,L,K,N,SI) -! CALL GRACAH1 (I, J, M, L, K, N, SI) +! CALL GRACAH1 (I, J, M, L, K, N, SI) ! CALL GRACAH(I,J,M,L,K,N,SI) - IF (MOD(I + J + M + L,4) /= 0) SI = -SI - ENDIF - IF (SAVE) RACA(I,J,K,L,M,N) = SI - RETURN - END SUBROUTINE SIXJ + IF (MOD(I + J + M + L,4) /= 0) SI = -SI + ENDIF + IF (SAVE) RACA(I,J,K,L,M,N) = SI + RETURN + END SUBROUTINE SIXJ diff --git a/src/lib/librang90/sixj1.f90 b/src/lib/librang90/sixj1.f90 index 534e02c14..ebf501ea0 100644 --- a/src/lib/librang90/sixj1.f90 +++ b/src/lib/librang90/sixj1.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ1(I,J,K,L,M,ITIK,SI) + SUBROUTINE SIXJ1(I,J,K,L,M,ITIK,SI) ! ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * @@ -16,84 +16,84 @@ SUBROUTINE SIXJ1(I,J,K,L,M,ITIK,SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, HALF, ONE, TWO, THREE !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I + USE ixjtik_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: I, J, K, L, M - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE), INTENT(OUT) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE), INTENT(OUT) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IFA - REAL(DOUBLE) :: AS, AKA, A, B, C + INTEGER :: IFA + REAL(DOUBLE) :: AS, AKA, A, B, C !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(I,J,K,L,M,2) == 0) RETURN - ENDIF - IFA = (I + J + K)/2 - AS = DBLE(IFA) - AKA = ONE - IF (MOD(IFA,2) /= 0) AKA = -AKA - A = DBLE(K) - B = DBLE(J) - C = DBLE(I) - IF (I < M) THEN - IF (J < L) THEN + IF (IXJTIK(I,J,K,L,M,2) == 0) RETURN + ENDIF + IFA = (I + J + K)/2 + AS = DBLE(IFA) + AKA = ONE + IF (MOD(IFA,2) /= 0) AKA = -AKA + A = DBLE(K) + B = DBLE(J) + C = DBLE(I) + IF (I < M) THEN + IF (J < L) THEN ! M > I, L > J. SI = AKA*DSQRT((AS + TWO)*(AS + THREE)*(AS - A + ONE)*(AS - A + TWO& )/((B + ONE)*(B + TWO)*(B + THREE)*(C + ONE)*(C + TWO)*(C + & - THREE))) - ELSE IF (J == L) THEN + THREE))) + ELSE IF (J == L) THEN ! M > I, L = J. SI = (-AKA)*DSQRT(TWO*(AS + TWO)*(AS - C)*(AS - B + ONE)*(AS - A + & - ONE)/(B*(B + ONE)*(B + TWO)*(C + ONE)*(C + TWO)*(C + THREE))) - ELSE + ONE)/(B*(B + ONE)*(B + TWO)*(C + ONE)*(C + TWO)*(C + THREE))) + ELSE ! M > I, L < J. SI = AKA*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + ONE)*(AS - B + TWO& - )/((B - ONE)*B*(B + ONE)*(C + ONE)*(C + TWO)*(C + THREE))) - ENDIF - ELSE IF (I == M) THEN - IF (J < L) THEN + )/((B - ONE)*B*(B + ONE)*(C + ONE)*(C + TWO)*(C + THREE))) + ENDIF + ELSE IF (I == M) THEN + IF (J < L) THEN ! M = L, L > J. SI = (-AKA)*DSQRT((AS + TWO)*(AS - C + ONE)*(AS - B)*(AS - A + ONE)& - *TWO/((B + ONE)*(B + TWO)*(B + THREE)*C*(C + ONE)*(C + TWO))) - ELSE IF (J == L) THEN + *TWO/((B + ONE)*(B + TWO)*(B + THREE)*C*(C + ONE)*(C + TWO))) + ELSE IF (J == L) THEN ! M = I, L = J. SI = (-AKA)*((B*B + C*C - A*A)*HALF + B + C - A)/DSQRT(B*(B + ONE)*& - (B + TWO)*C*(C + ONE)*(C + TWO)) - ELSE + (B + TWO)*C*(C + ONE)*(C + TWO)) + ELSE ! M = I, L < J. SI = AKA*DSQRT((AS + ONE)*(AS - C)*(AS - B + ONE)*(AS - A)*TWO/((B& - - ONE)*B*(B + ONE)*C*(C + ONE)*(C + TWO))) - ENDIF - ELSE - IF (J < L) THEN + - ONE)*B*(B + ONE)*C*(C + ONE)*(C + TWO))) + ENDIF + ELSE + IF (J < L) THEN ! M < I, L > J. SI = AKA*DSQRT((AS - C + ONE)*(AS - C + TWO)*(AS - B - ONE)*(AS - B& - )/((B + ONE)*(B + TWO)*(B + THREE)*(C - ONE)*C*(C + ONE))) - ELSE IF (J == L) THEN + )/((B + ONE)*(B + TWO)*(B + THREE)*(C - ONE)*C*(C + ONE))) + ELSE IF (J == L) THEN ! M < I, L = J. SI = AKA*DSQRT((AS + ONE)*(AS - C + ONE)*(AS - B)*(AS - A)*TWO/(B*(& - B + ONE)*(B + TWO)*(C - ONE)*C*(C + ONE))) - ELSE + B + ONE)*(B + TWO)*(C - ONE)*C*(C + ONE))) + ELSE ! M < I, L < J. SI = AKA*DSQRT(AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((B - ONE)*B*(& - B + ONE)*(C - ONE)*C*(C + ONE))) - ENDIF - ENDIF - RETURN - END SUBROUTINE SIXJ1 + B + ONE)*(C - ONE)*C*(C + ONE))) + ENDIF + ENDIF + RETURN + END SUBROUTINE SIXJ1 diff --git a/src/lib/librang90/sixj1_I.f90 b/src/lib/librang90/sixj1_I.f90 index c23c4a770..b4e3b31e1 100644 --- a/src/lib/librang90/sixj1_I.f90 +++ b/src/lib/librang90/sixj1_I.f90 @@ -1,6 +1,6 @@ MODULE sixj1_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj1 (I, J, K, L, M, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: I diff --git a/src/lib/librang90/sixj2.f90 b/src/lib/librang90/sixj2.f90 index 1ba9f0671..b6f7408ec 100644 --- a/src/lib/librang90/sixj2.f90 +++ b/src/lib/librang90/sixj2.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ2(J,K,L,M,N,ITIK,SI) + SUBROUTINE SIXJ2(J,K,L,M,N,ITIK,SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -15,217 +15,217 @@ SUBROUTINE SIXJ2(J,K,L,M,N,ITIK,SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, HALF, ONE, TWO, THREE, FOUR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I + USE ixjtik_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J, K, L, M, N - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE), INTENT(OUT) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE), INTENT(OUT) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I1 - REAL(DOUBLE) :: AS, A, B, C, AKA, X1, X2, X3 + INTEGER :: I1 + REAL(DOUBLE) :: AS, A, B, C, AKA, X1, X2, X3 !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(J,K,L,M,N,4) == 0) RETURN - ENDIF - I1 = (J + K + L)/2 - AS = DBLE(I1) - A = DBLE(L) - B = DBLE(J) - C = DBLE(K) - AKA = ONE - IF (MOD(I1,2) /= 0) AKA = -AKA - IF (J - N == 4) THEN + IF (IXJTIK(J,K,L,M,N,4) == 0) RETURN + ENDIF + I1 = (J + K + L)/2 + AS = DBLE(I1) + A = DBLE(L) + B = DBLE(J) + C = DBLE(K) + AKA = ONE + IF (MOD(I1,2) /= 0) AKA = -AKA + IF (J - N == 4) THEN ! -2 - IF (K - M == 4) THEN + IF (K - M == 4) THEN ! I -2 -2 SI = AKA*DSQRT((AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((B - THREE)*(B& - - TWO)*(B - ONE)*B*(B + ONE))) + - TWO)*(B - ONE)*B*(B + ONE))) SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - & - A)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 4) THEN + A)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 4) THEN ! V P(12) 2 -2 SI = AKA*DSQRT((AS - C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS& - C)/((C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR)*(C + TWO + & - THREE))) + THREE))) SI = SI*DSQRT((AS - B + ONE)*(AS - B + TWO)*(AS - B + THREE)*(AS - & - B + FOUR)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ELSE IF (K - M == 2) THEN + B + FOUR)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ELSE IF (K - M == 2) THEN ! II P(12) -1 -2 SI = AKA*TWO*DSQRT((AS - ONE)*AS*(AS + ONE)/((C - TWO)*(C - ONE)*C*& - (C + ONE)*(C + TWO))) + (C + ONE)*(C + TWO))) SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)*(AS - C)*(AS& - - B + ONE)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ELSE IF (M - K == 2) THEN + - B + ONE)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ELSE IF (M - K == 2) THEN ! IV P(12) 1 -2 SI = AKA*TWO*DSQRT((AS + ONE)*(AS - A)*(AS - C - TWO)*(AS - C - ONE& - )*(AS - C)/(C*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) + )*(AS - C)/(C*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) SI = SI*DSQRT((AS - B + ONE)*(AS - B + TWO)*(AS - B + THREE)/((B - & - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ELSE IF (K - M == 0) THEN + THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ELSE IF (K - M == 0) THEN ! III P(12) 0 -2 SI = AKA*DSQRT(TWO*THREE*AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((C& - - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) + - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + ONE)*(AS - B + TWO)& - /((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ENDIF + /((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ENDIF ! 2 - ELSE IF (N - J == 4) THEN - IF (K - M == 4) THEN + ELSE IF (N - J == 4) THEN + IF (K - M == 4) THEN ! V -2 2 SI = AKA*DSQRT((AS - B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS& - B)/((B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR)*(B + TWO + & - THREE))) + THREE))) SI = SI*DSQRT((AS - C + ONE)*(AS - C + TWO)*(AS - C + THREE)*(AS - & - C + FOUR)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 4) THEN + C + FOUR)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 4) THEN ! 1 2 2 SI = AKA*DSQRT((AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS& - A + ONE)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*& - (B + ONE))) + (B + ONE))) SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO& )/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))& - ) - ELSE IF (K - M == 2) THEN + ) + ELSE IF (K - M == 2) THEN ! 3 -1 2 SI = -AKA*DSQRT((AS - A + ONE)*(AS + TWO)*(AS - B - TWO)*(AS - B - & ONE)*(AS - B)/((B + TWO + THREE)*(B + FOUR)*(B + THREE)*(B + TWO& - )*(B + ONE))) + )*(B + ONE))) SI = SI*TWO*DSQRT((AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((& - C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 2) THEN + C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 2) THEN ! 2 1 2 SI = -AKA*DSQRT((AS - B)*(AS - C + ONE)*(AS - A + THREE)*(AS - A + & TWO)*(AS - A + ONE)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B& - + TWO)*(B + ONE))) + + TWO)*(B + ONE))) SI = SI*TWO*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((C + FOUR)*(& - C + THREE)*(C + TWO)*(C + ONE)*C)) - ELSE IF (K - M == 0) THEN + C + THREE)*(C + TWO)*(C + ONE)*C)) + ELSE IF (K - M == 0) THEN ! 5 0 2 SI = AKA*DSQRT(THREE*TWO*(AS - B)*(AS - B - ONE)*(AS - C + TWO)*(AS& - C + ONE)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*& - (B + ONE))) + (B + ONE))) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& - /((C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) - ENDIF - ELSE IF (J - N == 2) THEN + /((C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) + ENDIF + ELSE IF (J - N == 2) THEN ! -1 - IF (K - M == 4) THEN + IF (K - M == 4) THEN ! II P(12) -2 -1 SI = AKA*TWO*DSQRT((AS - ONE)*AS*(AS + ONE)/((B - TWO)*(B - ONE)*B*& - (B + ONE)*(B + TWO))) + (B + ONE)*(B + TWO))) SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)*(AS - B)*(AS& - - C + ONE)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 4) THEN + - C + ONE)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 4) THEN ! 3 P(12) 2 -1 SI = -AKA*DSQRT((AS - A + ONE)*(AS + TWO)*(AS - C - TWO)*(AS - C - & ONE)*(AS - C)/((C + TWO + THREE)*(C + FOUR)*(C + THREE)*(C + TWO& - )*(C + ONE))) + )*(C + ONE))) SI = SI*TWO*DSQRT((AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((& - B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) - ELSE IF (K - M == 2) THEN + B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) + ELSE IF (K - M == 2) THEN ! VI -1 -1 SI = AKA*((A + B)*(A - B + TWO) - (C - TWO)*(C - B + TWO))/DSQRT((B& - - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)) + - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)) SI = SI*DSQRT(AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((C - TWO)*(C& - - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 2) THEN + - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 2) THEN ! VIII P(12) 1 -1 SI = AKA*((A + C + FOUR)*(A - C - TWO) - (B - TWO)*(B + C + FOUR))/& - DSQRT(C*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR)) + DSQRT(C*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR)) SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + ONE)*(AS - B + TWO)& - /((B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) - ELSE IF (K - M == 0) THEN + /((B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) + ELSE IF (K - M == 0) THEN ! VII P(12) 0 -1 SI = AKA*HALF*((A + C + TWO)*(A - C) - B*B + FOUR)/DSQRT((C - ONE)*& - C*(C + ONE)*(C + TWO)*(C + THREE)) + C*(C + ONE)*(C + TWO)*(C + THREE)) SI = SI*DSQRT(THREE*TWO*(AS + ONE)*(AS - A)*(AS - C)*(AS - B + ONE)& - /((B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) - ENDIF - ELSE IF (N - J == 2) THEN + /((B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) + ENDIF + ELSE IF (N - J == 2) THEN ! 1 - IF (K - M == 4) THEN + IF (K - M == 4) THEN ! IV -2 1 SI = AKA*TWO*DSQRT((AS + ONE)*(AS - A)*(AS - B - TWO)*(AS - B - ONE& - )*(AS - B)/(B*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) + )*(AS - B)/(B*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) SI = SI*DSQRT((AS - C + ONE)*(AS - C + TWO)*(AS - C + THREE)/((C - & - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 4) THEN + THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 4) THEN ! 2 P(12) 2 1 SI = -AKA*DSQRT((AS - C)*(AS - B + ONE)*(AS - A + THREE)*(AS - A + & TWO)*(AS - A + ONE)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C& - + TWO)*(C + ONE))) + + TWO)*(C + ONE))) SI = SI*TWO*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((B + FOUR)*(& - B + THREE)*(B + TWO)*(B + ONE)*B)) - ELSE IF (K - M == 2) THEN + B + THREE)*(B + TWO)*(B + ONE)*B)) + ELSE IF (K - M == 2) THEN ! VIII -1 1 SI = AKA*((A + B + FOUR)*(A - B - TWO) - (C - TWO)*(B + C + FOUR))/& - DSQRT(B*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR)) + DSQRT(B*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR)) SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + ONE)*(AS - C + TWO)& - /((C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 2) THEN + /((C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 2) THEN ! 4 1 1 SI = AKA*(THREE*(AS - B)*(AS - C) - (AS - A)*(AS + FOUR))/DSQRT((B& - + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B) + + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& - /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) - ELSE IF (K - M == 0) THEN + /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) + ELSE IF (K - M == 0) THEN ! 6 P(12) 0 1 SI = -AKA*((AS - B - ONE)*(AS - C) - (AS - A)*(AS + THREE))/DSQRT((& - B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B) + B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B) SI = SI*DSQRT(THREE*TWO*(AS - B)*(AS - C + ONE)*(AS - A + ONE)*(AS& - + TWO)/((C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) - ENDIF - ELSE IF (N - J == 0) THEN + + TWO)/((C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) + ENDIF + ELSE IF (N - J == 0) THEN ! 0 - IF (K - M == 4) THEN + IF (K - M == 4) THEN ! III -2 0 SI = AKA*DSQRT(THREE*TWO*AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((B& - - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) + - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + ONE)*(AS - C + TWO)& - /((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 4) THEN + /((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 4) THEN ! 5 2 0 SI = AKA*DSQRT(THREE*TWO*(AS - C)*(AS - C - ONE)*(AS - B + TWO)*(AS& - B + ONE)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*& - (C + ONE))) + (C + ONE))) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& - /((B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) - ELSE IF (K - M == 2) THEN + /((B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) + ELSE IF (K - M == 2) THEN ! VII -1 0 SI = AKA*HALF*((A + B + TWO)*(A - B) - C*C + FOUR)/DSQRT((B - ONE)*& - B*(B + ONE)*(B + TWO)*(B + THREE)) + B*(B + ONE)*(B + TWO)*(B + THREE)) SI = SI*DSQRT(THREE*TWO*(AS + ONE)*(AS - A)*(AS - B)*(AS - C + ONE)& - /((C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 2) THEN + /((C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 2) THEN ! 6 1 0 SI = -AKA*((AS - C - ONE)*(AS - B) - (AS - A)*(AS + THREE))/DSQRT((& - C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C) + C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C) SI = SI*DSQRT(THREE*TWO*(AS - C)*(AS - B + ONE)*(AS - A + ONE)*(AS& - + TWO)/((B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) - ELSE IF (K - M == 0) THEN + + TWO)/((B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) + ELSE IF (K - M == 0) THEN ! IX 0 0 - X1 = (AS - B)*(AS - B - ONE)*(AS - C)*(AS - C - ONE) - X2 = FOUR*(AS - B)*(AS - C)*(AS - A)*(AS + TWO) - X3 = (AS - A)*(AS - A - ONE)*(AS + THREE)*(AS + TWO) + X1 = (AS - B)*(AS - B - ONE)*(AS - C)*(AS - C - ONE) + X2 = FOUR*(AS - B)*(AS - C)*(AS - A)*(AS + TWO) + X3 = (AS - A)*(AS - A - ONE)*(AS + THREE)*(AS + TWO) SI = AKA*(X1 - X2 + X3)/DSQRT((B - ONE)*B*(B + ONE)*(B + TWO)*(B + & - THREE)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)) - ENDIF - ENDIF - RETURN - END SUBROUTINE SIXJ2 + THREE)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)) + ENDIF + ENDIF + RETURN + END SUBROUTINE SIXJ2 diff --git a/src/lib/librang90/sixj2_I.f90 b/src/lib/librang90/sixj2_I.f90 index 877d558bd..aee6deea6 100644 --- a/src/lib/librang90/sixj2_I.f90 +++ b/src/lib/librang90/sixj2_I.f90 @@ -1,6 +1,6 @@ MODULE sixj2_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj2 (J, K, L, M, N, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J @@ -10,7 +10,7 @@ SUBROUTINE sixj2 (J, K, L, M, N, ITIK, SI) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: ITIK REAL(DOUBLE), INTENT(OUT) :: SI -!VAST.../CONSTS/ ZERO(IN), HALF(IN), ONE(IN), TWO(IN), THREE(IN) +!VAST.../CONSTS/ ZERO(IN), HALF(IN), ONE(IN), TWO(IN), THREE(IN) !VAST.../CONSTS/ FOUR(IN) !VAST...Calls: IXJTIK END SUBROUTINE diff --git a/src/lib/librang90/sixj3.f90 b/src/lib/librang90/sixj3.f90 index 900e19068..ece0a6948 100644 --- a/src/lib/librang90/sixj3.f90 +++ b/src/lib/librang90/sixj3.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ3(J, K, L, M, N, ITIK, SI) + SUBROUTINE SIXJ3(J, K, L, M, N, ITIK, SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -15,495 +15,495 @@ SUBROUTINE SIXJ3(J, K, L, M, N, ITIK, SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE, TWO, THREE, FOUR, SEVEN !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I + USE ixjtik_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J, K, L, M, N - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE), INTENT(OUT) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE), INTENT(OUT) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I1 - REAL(DOUBLE) :: AS, A, B, C, AKA + INTEGER :: I1 + REAL(DOUBLE) :: AS, A, B, C, AKA !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(J,K,L,M,N,6) == 0) RETURN - ENDIF - I1 = (J + K + L)/2 - AS = DBLE(I1) - A = DBLE(L) - B = DBLE(J) - C = DBLE(K) - AKA = ONE - IF (MOD(I1,2) /= 0) AKA = -AKA - IF (J - N == 6) THEN + IF (IXJTIK(J,K,L,M,N,6) == 0) RETURN + ENDIF + I1 = (J + K + L)/2 + AS = DBLE(I1) + A = DBLE(L) + B = DBLE(J) + C = DBLE(K) + AKA = ONE + IF (MOD(I1,2) /= 0) AKA = -AKA + IF (J - N == 6) THEN ! -3 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 -3 SI = AKA*DSQRT((AS + ONE)*AS*(AS - ONE)*(AS - TWO)*(AS - THREE)*(AS& - FOUR)/((B + ONE)*B*(B - ONE)*(B - TWO)*(B - THREE)*(B - FOUR)& - *(B - THREE - TWO))) + *(B - THREE - TWO))) SI = SI*DSQRT((AS - A - THREE - TWO)*(AS - A - FOUR)*(AS - A - & THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - A)/((C + ONE)*C*(C - & - ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO))) - ELSE IF (M - K == 6) THEN + ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO))) + ELSE IF (M - K == 6) THEN ! 3 -3 SI = AKA*DSQRT((AS - C)*(AS - C - ONE)*(AS - C - TWO)*(AS - C - & THREE)*(AS - C - FOUR)*(AS - C - THREE - TWO)/((B + ONE)*B*(B - & - ONE)*(B - TWO)*(B - THREE)*(B - FOUR)*(B - THREE - TWO))) + ONE)*(B - TWO)*(B - THREE)*(B - FOUR)*(B - THREE - TWO))) SI = SI*DSQRT((AS - B + THREE + THREE)*(AS - B + THREE + TWO)*(AS& - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C& + FOUR + THREE)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR& - )*(C + THREE)*(C + TWO)*(C + ONE))) - ELSE IF (K - M == 4) THEN + )*(C + THREE)*(C + TWO)*(C + ONE))) + ELSE IF (K - M == 4) THEN ! -2 -3 SI = AKA*DSQRT(TWO*THREE*(AS - C)*(AS - B + ONE)*(AS - THREE)*(AS& - TWO)*(AS - ONE)*AS*(AS + ONE)/((B - THREE - TWO)*(B - FOUR)*(& - B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) SI = SI*DSQRT((AS - A - FOUR)*(AS - A - THREE)*(AS - A - TWO)*(AS& - A - ONE)*(AS - A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)& - *C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 4) THEN + *C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 4) THEN ! 2 -3 SI = AKA*DSQRT(TWO*THREE*(AS + ONE)*(AS - A)*(AS - C - FOUR)*(AS - & C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((C + THREE + & THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + & - ONE)*C)) + ONE)*C)) SI = SI*DSQRT((AS - B + THREE + TWO)*(AS - B + FOUR)*(AS - B + & THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - THREE - TWO)*(B - & - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ELSE IF (K - M == 2) THEN + FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ELSE IF (K - M == 2) THEN ! -1 -3 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B& + TWO)*(AS - B + ONE)*(AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((B& - THREE - TWO)*(B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B& - + ONE))) + + ONE))) SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - & A)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + & - THREE))) - ELSE IF (M - K == 2) THEN + THREE))) + ELSE IF (M - K == 2) THEN ! 1 -3 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - ONE)*(AS& - A)*(AS - C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((& B - THREE - TWO)*(B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B& - + ONE))) + + ONE))) SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS& - B + ONE)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*& - (C + ONE)*C*(C - ONE))) - ELSE IF (M - K == 0) THEN + (C + ONE)*C*(C - ONE))) + ELSE IF (M - K == 0) THEN ! 0 -3 SI = AKA*TWO*DSQRT((THREE + TWO)*(AS + ONE)*AS*(AS - ONE)*(AS - A& - TWO)*(AS - A - ONE)*(AS - A)/((B - THREE - TWO)*(B - FOUR)*(B& - - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) + - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE))) SI = SI*DSQRT((AS - C - TWO)*(AS - C - ONE)*(AS - C)*(AS - B + & THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + FOUR)*(C + THREE)*(C& - + TWO)*(C + ONE)*C*(C - ONE)*(C - TWO))) - ENDIF - ELSE IF (N - J == 6) THEN + + TWO)*(C + ONE)*C*(C - ONE)*(C - TWO))) + ENDIF + ELSE IF (N - J == 6) THEN ! 3 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 3 SI = AKA*DSQRT((AS - B)*(AS - B - ONE)*(AS - B - TWO)*(AS - B - & THREE)*(AS - B - FOUR)*(AS - B - THREE - TWO)/((C + ONE)*C*(C - & - ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO))) + ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO))) SI = SI*DSQRT((AS - C + THREE + THREE)*(AS - C + THREE + TWO)*(AS& - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B& + FOUR + THREE)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR& - )*(B + THREE)*(B + TWO)*(B + ONE))) - ELSE IF (M - K == 6) THEN + )*(B + THREE)*(B + TWO)*(B + ONE))) + ELSE IF (M - K == 6) THEN ! 3 3 SI = AKA*DSQRT((AS - A + THREE + THREE)*(AS - A + THREE + TWO)*(AS& - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)/((B& + SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + & - THREE)*(B + TWO)*(B + ONE))) + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS + SEVEN)*(AS + THREE + THREE)*(AS + THREE + TWO)*& (AS + FOUR)*(AS + THREE)*(AS + TWO)/((C + SEVEN)*(C + THREE + & THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + & - ONE))) - ELSE IF (K - M == 4) THEN + ONE))) + ELSE IF (K - M == 4) THEN ! -2 3 SI = -AKA*DSQRT(TWO*THREE*(AS - A + ONE)*(AS + TWO)*(AS - B - FOUR)& *(AS - B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((B + & SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + & - THREE)*(B + TWO)*(B + ONE))) + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS - C + THREE + TWO)*(AS - C + FOUR)*(AS - C + & THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - FOUR)*(C - THREE)*(C& - - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 4) THEN + - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 4) THEN ! 2 3 SI = -AKA*DSQRT(TWO*THREE*(AS - B)*(AS - C + ONE)*(AS - A + THREE& + TWO)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A& + ONE)/((B + SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + & - FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) + FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS + THREE + THREE)*(AS + THREE + TWO)*(AS + FOUR)*(& AS + THREE)*(AS + TWO)/((C + THREE + THREE)*(C + THREE + TWO)*(C& - + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) - ELSE IF (K - M == 2) THEN + + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) + ELSE IF (K - M == 2) THEN ! -1 3 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - A + ONE)*(AS - A + TWO)*(& AS + THREE)*(AS + TWO)*(AS - B - THREE)*(AS - B - TWO)*(AS - B& - ONE)*(AS - B)/((B + SEVEN)*(B + THREE + THREE)*(B + THREE + & - TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS& - C + ONE)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + & - TWO)*(C + THREE))) - ELSE IF (M - K == 2) THEN + TWO)*(C + THREE))) + ELSE IF (M - K == 2) THEN ! 1 3 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C& + TWO)*(AS - C + ONE)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A& + TWO)*(AS - A + ONE)/((B + SEVEN)*(B + THREE + THREE)*(B + & - THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO& )/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*& - C*(C - ONE))) - ELSE IF (M - K == 0) THEN + C*(C - ONE))) + ELSE IF (M - K == 0) THEN ! 0 3 SI = -AKA*TWO*DSQRT((THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - B& - TWO)*(AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + & SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + & - THREE)*(B + TWO)*(B + ONE))) + THREE)*(B + TWO)*(B + ONE))) SI = SI*DSQRT((AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)*(AS + & FOUR)*(AS + THREE)*(AS + TWO)/((C + FOUR)*(C + THREE)*(C + TWO)*& - (C + ONE)*C*(C - ONE)*(C - TWO))) - ENDIF - ELSE IF (J - N == 4) THEN + (C + ONE)*C*(C - ONE)*(C - TWO))) + ENDIF + ELSE IF (J - N == 4) THEN ! -2 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 -2 SI = AKA*DSQRT(TWO*THREE*(AS - B)*(AS - C + ONE)*(AS - THREE)*(AS& - TWO)*(AS - ONE)*AS*(AS + ONE)/((C - THREE - TWO)*(C - FOUR)*(& - C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) SI = SI*DSQRT((AS - A - FOUR)*(AS - A - THREE)*(AS - A - TWO)*(AS& - A - ONE)*(AS - A)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)& - *B*(B + ONE)*(B + TWO))) - ELSE IF (M - K == 6) THEN + *B*(B + ONE)*(B + TWO))) + ELSE IF (M - K == 6) THEN ! 3 -2 SI = -AKA*DSQRT(TWO*THREE*(AS - A + ONE)*(AS + TWO)*(AS - C - FOUR)& *(AS - C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((C + & SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + & - THREE)*(C + TWO)*(C + ONE))) + THREE)*(C + TWO)*(C + ONE))) SI = SI*DSQRT((AS - B + THREE + TWO)*(AS - B + FOUR)*(AS - B + & THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - FOUR)*(B - THREE)*(B& - - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) - ELSE IF (K - M == 4) THEN + - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) + ELSE IF (K - M == 4) THEN ! -2 -2 SI = AKA*((TWO + THREE)*(AS - C)*(AS - B) - (AS + TWO)*(AS - A - & FOUR))*DSQRT((AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((B - FOUR)*(B& - - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) + - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO))) SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - & A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + & - TWO))) - ELSE IF (M - K == 4) THEN + TWO))) + ELSE IF (M - K == 4) THEN ! 2 -2 SI = -AKA*((TWO + THREE)*(AS + ONE)*(AS - A + ONE) - (AS - C + ONE)& *(AS - B + THREE + TWO))*DSQRT((AS - C - THREE)*(AS - C - TWO)*(& AS - C - ONE)*(AS - C)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - & - ONE)*B*(B + ONE)*(B + TWO))) + ONE)*B*(B + ONE)*(B + TWO))) SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS& - B + ONE)/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C& - + THREE)*(C + TWO)*(C + ONE)*C)) - ELSE IF (K - M == 2) THEN + + THREE)*(C + TWO)*(C + ONE)*C)) + ELSE IF (K - M == 2) THEN ! -1 -2 SI = AKA*(TWO*(AS - C - ONE)*(AS - B) - (AS + TWO)*(AS - A - THREE)& )*DSQRT(TWO*(THREE + TWO)*(AS - C)*(AS - B + ONE)*(AS - ONE)*AS*& (AS + ONE)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B + & - ONE)*(B + TWO))) + ONE)*(B + TWO))) SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)/((C - THREE)*(& - C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) - ELSE IF (M - K == 2) THEN + C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) + ELSE IF (M - K == 2) THEN ! 1 -2 SI = -AKA*(TWO*AS*(AS - A + ONE) - (AS - C + ONE)*(AS - B + FOUR))*& DSQRT(TWO*(THREE + TWO)*(AS + ONE)*(AS - A)*(AS - C - TWO)*(AS& - C - ONE)*(AS - C)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)& - *B*(B + ONE)*(B + TWO))) + *B*(B + ONE)*(B + TWO))) SI = SI*DSQRT((AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + & THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - & - ONE))) - ELSE IF (M - K == 0) THEN + ONE))) + ELSE IF (M - K == 0) THEN ! 0 -2 SI = -AKA*((AS - ONE)*(AS - A + ONE) - (AS - C + ONE)*(AS - B + & THREE))*DSQRT(TWO*THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - & ONE)*(AS - A)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B& - + ONE)*(B + TWO))) + + ONE)*(B + TWO))) SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + TWO)*(AS - B + ONE)& /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - & - TWO))) - ENDIF - ELSE IF (N - J == 4) THEN + TWO))) + ENDIF + ELSE IF (N - J == 4) THEN ! 2 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 2 SI = AKA*DSQRT(TWO*THREE*(AS + ONE)*(AS - A)*(AS - B - FOUR)*(AS - & B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((B + THREE + & THREE)*(B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + & - ONE)*B)) + ONE)*B)) SI = SI*DSQRT((AS - C + THREE + TWO)*(AS - C + FOUR)*(AS - C + & THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - THREE - TWO)*(C - & - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 6) THEN + FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 6) THEN ! 3 2 SI = -AKA*DSQRT(TWO*THREE*(AS - C)*(AS - B + ONE)*(AS - A + THREE& + TWO)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A& + ONE)/((C + SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + & - FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) SI = SI*DSQRT((AS + THREE + THREE)*(AS + THREE + TWO)*(AS + FOUR)*(& AS + THREE)*(AS + TWO)/((B + THREE + THREE)*(B + THREE + TWO)*(B& - + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) - ELSE IF (K - M == 4) THEN + + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) + ELSE IF (K - M == 4) THEN ! -2 2 SI = -AKA*((TWO + THREE)*(AS + ONE)*(AS - A + ONE) - (AS - B + ONE)& *(AS - C + THREE + TWO))*DSQRT((AS - B - THREE)*(AS - B - TWO)*(& AS - B - ONE)*(AS - B)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - & - ONE)*C*(C + ONE)*(C + TWO))) + ONE)*C*(C + ONE)*(C + TWO))) SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS& - C + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B& - + THREE)*(B + TWO)*(B + ONE)*B)) - ELSE IF (M - K == 4) THEN + + THREE)*(B + TWO)*(B + ONE)*B)) + ELSE IF (M - K == 4) THEN ! 2 2 SI = AKA*((TWO + THREE)*(AS - B)*(AS - C) - (AS - A)*(AS + THREE + & THREE))*DSQRT((AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(& AS - A + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*& - (B + THREE)*(B + TWO)*(B + ONE)*B)) + (B + THREE)*(B + TWO)*(B + ONE)*B)) SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO& )/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*& - (C + TWO)*(C + ONE)*C)) - ELSE IF (K - M == 2) THEN + (C + TWO)*(C + ONE)*C)) + ELSE IF (K - M == 2) THEN ! -1 2 SI = AKA*(TWO*(AS - A + TWO)*(AS + ONE) - (AS - B + ONE)*(AS - C + & FOUR))*DSQRT(TWO*(THREE + TWO)*(AS - A + ONE)*(AS + TWO)*(AS - B& - TWO)*(AS - B - ONE)*(AS - B)/((B + THREE + THREE)*(B + THREE& - + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) + + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) SI = SI*DSQRT((AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - & - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) - ELSE IF (M - K == 2) THEN + THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) + ELSE IF (M - K == 2) THEN ! 1 2 SI = -AKA*(TWO*(AS - B - ONE)*(AS - C) - (AS - A)*(AS + THREE + TWO& ))*DSQRT(TWO*(THREE + TWO)*(AS - B)*(AS - C + ONE)*(AS - A + & THREE)*(AS - A + TWO)*(AS - A + ONE)/((B + THREE + THREE)*(B + & - THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B)) SI = SI*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((C + THREE + TWO& - )*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) - ELSE IF (M - K == 0) THEN + )*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE))) + ELSE IF (M - K == 0) THEN ! 0 2 SI = AKA*((AS - B - TWO)*(AS - C) - (AS - A)*(AS + FOUR))*DSQRT(TWO& *THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C + TWO)*(AS& - C + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B& - + THREE)*(B + TWO)*(B + ONE)*B)) + + THREE)*(B + TWO)*(B + ONE)*B)) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - & - TWO))) - ENDIF - ELSE IF (J - N == 2) THEN + TWO))) + ENDIF + ELSE IF (J - N == 2) THEN ! - 1 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 -1 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C& + TWO)*(AS - C + ONE)*(AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((C& - THREE - TWO)*(C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C& - + ONE))) + + ONE))) SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - & A)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + & - THREE))) - ELSE IF (M - K == 6) THEN + THREE))) + ELSE IF (M - K == 6) THEN ! 3 -1 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - A + ONE)*(AS - A + TWO)*(& AS + THREE)*(AS + TWO)*(AS - C - THREE)*(AS - C - TWO)*(AS - C& - ONE)*(AS - C)/((C + SEVEN)*(C + THREE + THREE)*(C + THREE + & - TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS& - B + ONE)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + & - TWO)*(B + THREE))) - ELSE IF (K - M == 4) THEN + TWO)*(B + THREE))) + ELSE IF (K - M == 4) THEN ! -2 -1 SI = AKA*(TWO*(AS - B - ONE)*(AS - C) - (AS + TWO)*(AS - A - THREE)& )*DSQRT(TWO*(THREE + TWO)*(AS - B)*(AS - C + ONE)*(AS - ONE)*AS*& (AS + ONE)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + & - ONE)*(C + TWO))) + ONE)*(C + TWO))) SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)/((B - THREE)*(& - B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) - ELSE IF (M - K == 4) THEN + B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) + ELSE IF (M - K == 4) THEN ! 2 -1 SI = AKA*(TWO*(AS - A + TWO)*(AS + ONE) - (AS - C + ONE)*(AS - B + & FOUR))*DSQRT(TWO*(THREE + TWO)*(AS - A + ONE)*(AS + TWO)*(AS - C& - TWO)*(AS - C - ONE)*(AS - C)/((C + THREE + THREE)*(C + THREE& - + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) + + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) SI = SI*DSQRT((AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - & - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) - ELSE IF (K - M == 2) THEN + THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE))) + ELSE IF (K - M == 2) THEN ! -1 -1 SI = AKA*(TWO*THREE*(AS - C)*(AS - C - ONE)*(AS - B - ONE)*(AS - B)& - TWO*FOUR*(AS - C)*(AS - B)*(AS + TWO)*(AS - A - TWO) + (AS + & - THREE)*(AS + TWO)*(AS - A - THREE)*(AS - A - TWO)) + THREE)*(AS + TWO)*(AS - A - THREE)*(AS - A - TWO)) SI = SI*DSQRT(AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((B - THREE)*(B& - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)*(C - THREE)*& - (C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) - ELSE IF (M - K == 2) THEN + (C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE))) + ELSE IF (M - K == 2) THEN ! 1 -1 SI = AKA*(TWO*THREE*(AS + ONE)*AS*(AS - A + ONE)*(AS - A + TWO) - & TWO*FOUR*(AS + ONE)*(AS - A + ONE)*(AS - C + ONE)*(AS - B + & THREE) + (AS - C + ONE)*(AS - C + TWO)*(AS - B + FOUR)*(AS - B& - + THREE)) + + THREE)) SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + TWO)*(AS - B + ONE)& /((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + & THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + & - ONE)*C*(C - ONE))) - ELSE IF (M - K == 0) THEN + ONE)*C*(C - ONE))) + ELSE IF (M - K == 0) THEN ! 0 -1 SI = AKA*TWO*(AS*(AS - ONE)*(AS - A + ONE)*(AS - A + TWO) - THREE*& AS*(AS - A + ONE)*(AS - C + ONE)*(AS - B + TWO) + (AS - C + ONE)& - *(AS - C + TWO)*(AS - B + THREE)*(AS - B + TWO)) + *(AS - C + TWO)*(AS - B + THREE)*(AS - B + TWO)) SI = SI*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - C)*(AS - B + ONE)/((B& - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)*& (C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - TWO)& - )) - ENDIF - ELSE IF (N - J == 2) THEN + )) + ENDIF + ELSE IF (N - J == 2) THEN ! - 1 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 1 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - ONE)*(AS& - A)*(AS - B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((& C - THREE - TWO)*(C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C& - + ONE))) + + ONE))) SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS& - C + ONE)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*& - (B + ONE)*B*(B - ONE))) - ELSE IF (M - K == 6) THEN + (B + ONE)*B*(B - ONE))) + ELSE IF (M - K == 6) THEN ! 3 1 SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B& + TWO)*(AS - B + ONE)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A& + TWO)*(AS - A + ONE)/((C + SEVEN)*(C + THREE + THREE)*(C + & - THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE))) SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO& )/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*& - B*(B - ONE))) - ELSE IF (K - M == 4) THEN + B*(B - ONE))) + ELSE IF (K - M == 4) THEN ! -2 1 SI = -AKA*(TWO*AS*(AS - A + ONE) - (AS - B + ONE)*(AS - C + FOUR))*& DSQRT(TWO*(THREE + TWO)*(AS + ONE)*(AS - A)*(AS - B - TWO)*(AS& - B - ONE)*(AS - B)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)& - *C*(C + ONE)*(C + TWO))) + *C*(C + ONE)*(C + TWO))) SI = SI*DSQRT((AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + & THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - & - ONE))) - ELSE IF (M - K == 4) THEN + ONE))) + ELSE IF (M - K == 4) THEN ! 2 1 SI = -AKA*(TWO*(AS - C - ONE)*(AS - B) - (AS - A)*(AS + THREE + TWO& ))*DSQRT(TWO*(THREE + TWO)*(AS - C)*(AS - B + ONE)*(AS - A + & THREE)*(AS - A + TWO)*(AS - A + ONE)/((C + THREE + THREE)*(C + & - THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C)) SI = SI*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((B + THREE + TWO& - )*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) - ELSE IF (M - K == 2) THEN + )*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE))) + ELSE IF (M - K == 2) THEN ! 1 1 SI = AKA*(TWO*THREE*(AS - B)*(AS - B - ONE)*(AS - C)*(AS - C - ONE)& - TWO*FOUR*(AS - B)*(AS - C)*(AS - A)*(AS + FOUR) + (AS - A)*(& - AS - A - ONE)*(AS + THREE + TWO)*(AS + FOUR)) + AS - A - ONE)*(AS + THREE + TWO)*(AS + FOUR)) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& /((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B& *(B - ONE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C& - + ONE)*C*(C - ONE))) - ELSE IF (K - M == 2) THEN + + ONE)*C*(C - ONE))) + ELSE IF (K - M == 2) THEN ! -1 1 SI = AKA*(TWO*THREE*(AS + ONE)*AS*(AS - A + ONE)*(AS - A + TWO) - & TWO*FOUR*(AS + ONE)*(AS - A + ONE)*(AS - B + ONE)*(AS - C + & THREE) + (AS - B + ONE)*(AS - B + TWO)*(AS - C + FOUR)*(AS - C& - + THREE)) + + THREE)) SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + TWO)*(AS - C + ONE)& /((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + & THREE)*(B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + & - ONE)*B*(B - ONE))) - ELSE IF (M - K == 0) THEN + ONE)*B*(B - ONE))) + ELSE IF (M - K == 0) THEN ! 0 1 SI = -AKA*TWO*((AS - B - ONE)*(AS - B - TWO)*(AS - C)*(AS - C - ONE& ) - THREE*(AS - B - ONE)*(AS - C)*(AS - A)*(AS + THREE) + (AS - & - A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE)) + A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE)) SI = SI*DSQRT(THREE*(AS - B)*(AS - C + ONE)*(AS - A + ONE)*(AS + & TWO)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + & ONE)*B*(B - ONE)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C& - - ONE)*(C - TWO))) - ENDIF - ELSE IF (J - N == 0) THEN + - ONE)*(C - TWO))) + ENDIF + ELSE IF (J - N == 0) THEN ! 0 - IF (K - M == 6) THEN + IF (K - M == 6) THEN ! -3 0 SI = AKA*TWO*DSQRT((THREE + TWO)*(AS + ONE)*AS*(AS - ONE)*(AS - A& - TWO)*(AS - A - ONE)*(AS - A)/((C - THREE - TWO)*(C - FOUR)*(C& - - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) + - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE))) SI = SI*DSQRT((AS - B - TWO)*(AS - B - ONE)*(AS - B)*(AS - C + & THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + FOUR)*(B + THREE)*(B& - + TWO)*(B + ONE)*B*(B - ONE)*(B - TWO))) - ELSE IF (M - K == 6) THEN + + TWO)*(B + ONE)*B*(B - ONE)*(B - TWO))) + ELSE IF (M - K == 6) THEN ! 3 0 SI = -AKA*TWO*DSQRT((THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - C& - TWO)*(AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + & SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + & - THREE)*(C + TWO)*(C + ONE))) + THREE)*(C + TWO)*(C + ONE))) SI = SI*DSQRT((AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)*(AS + & FOUR)*(AS + THREE)*(AS + TWO)/((B + FOUR)*(B + THREE)*(B + TWO)*& - (B + ONE)*B*(B - ONE)*(B - TWO))) - ELSE IF (K - M == 4) THEN + (B + ONE)*B*(B - ONE)*(B - TWO))) + ELSE IF (K - M == 4) THEN ! -2 0 SI = -AKA*((AS - ONE)*(AS - A + ONE) - (AS - B + ONE)*(AS - C + & THREE))*DSQRT(TWO*THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - & ONE)*(AS - A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C& - + ONE)*(C + TWO))) + + ONE)*(C + TWO))) SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + TWO)*(AS - C + ONE)& /((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - & - TWO))) - ELSE IF (M - K == 4) THEN + TWO))) + ELSE IF (M - K == 4) THEN ! 2 0 SI = AKA*((AS - C - TWO)*(AS - B) - (AS - A)*(AS + FOUR))*DSQRT(TWO& *THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B + TWO)*(AS& - B + ONE)/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C& - + THREE)*(C + TWO)*(C + ONE)*C)) + + THREE)*(C + TWO)*(C + ONE)*C)) SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)& /((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - & - TWO))) - ELSE IF (K - M == 2) THEN + TWO))) + ELSE IF (K - M == 2) THEN ! -1 0 SI = AKA*TWO*(AS*(AS - ONE)*(AS - A + ONE)*(AS - A + TWO) - THREE*& AS*(AS - A + ONE)*(AS - B + ONE)*(AS - C + TWO) + (AS - B + ONE)& - *(AS - B + TWO)*(AS - C + THREE)*(AS - C + TWO)) + *(AS - B + TWO)*(AS - C + THREE)*(AS - C + TWO)) SI = SI*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - B)*(AS - C + ONE)/((C& - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)*& (B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - TWO)& - )) - ELSE IF (M - K == 2) THEN + )) + ELSE IF (M - K == 2) THEN ! 1 0 SI = -AKA*TWO*((AS - C - ONE)*(AS - C - TWO)*(AS - B)*(AS - B - ONE& ) - THREE*(AS - C - ONE)*(AS - B)*(AS - A)*(AS + THREE) + (AS - & - A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE)) + A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE)) SI = SI*DSQRT(THREE*(AS - C)*(AS - B + ONE)*(AS - A + ONE)*(AS + & TWO)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + & ONE)*C*(C - ONE)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B& - - ONE)*(B - TWO))) - ELSE IF (K - M == 0) THEN + - ONE)*(B - TWO))) + ELSE IF (K - M == 0) THEN ! 0 0 SI = AKA*((AS - B)*(AS - B - ONE)*(AS - B - TWO)*(AS - C)*(AS - C& - ONE)*(AS - C - TWO) - THREE*THREE*(AS - B)*(AS - B - ONE)*(AS& - C)*(AS - C - ONE)*(AS - A)*(AS + TWO) + THREE*THREE*(AS - B)*& (AS - C)*(AS - A)*(AS - A - ONE)*(AS + THREE)*(AS + TWO) - (AS& - A)*(AS - A - ONE)*(AS - A - TWO)*(AS + FOUR)*(AS + THREE)*(AS& - + TWO)) + + TWO)) SI = SI/DSQRT((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE& )*(B - TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - & - ONE)*(C - TWO)) - ENDIF - ENDIF - RETURN - END SUBROUTINE SIXJ3 + ONE)*(C - TWO)) + ENDIF + ENDIF + RETURN + END SUBROUTINE SIXJ3 diff --git a/src/lib/librang90/sixj35.f90 b/src/lib/librang90/sixj35.f90 index 0f2970a3d..551b7ce12 100644 --- a/src/lib/librang90/sixj35.f90 +++ b/src/lib/librang90/sixj35.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ35(J,K,L,M,N,ITIK,SI) + SUBROUTINE SIXJ35(J,K,L,M,N,ITIK,SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -8,140 +8,140 @@ SUBROUTINE SIXJ35(J,K,L,M,N,ITIK,SI) ! | M/2 N/2 3/2 | [B.M.X. 75] * ! * ! Written by G. Gaigalas, * -! Vanderbilt University, Nashville October 1996 * +! Vanderbilt University, Nashville October 1996 * ! Transform to fortran 90/95 by G. Gaigalas December 2012 * ! The last modification made by G. Gaigalas October 2017 * ! * !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE, TWO, THREE, FOUR !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I + USE ixjtik_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J, K, L, M, N - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE), INTENT(OUT) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE), INTENT(OUT) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I1 - REAL(DOUBLE) :: AS, A, B, C, AKA + INTEGER :: I1 + REAL(DOUBLE) :: AS, A, B, C, AKA !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(J,K,L,M,N,3) == 0) RETURN - ENDIF - I1 = (J + K + L)/2 - AS = DBLE(I1) - A = DBLE(L) - B = DBLE(J) - C = DBLE(K) - AKA = ONE - IF (MOD(I1,2) /= 0) AKA = -AKA - IF (J - N == 3) THEN + IF (IXJTIK(J,K,L,M,N,3) == 0) RETURN + ENDIF + I1 = (J + K + L)/2 + AS = DBLE(I1) + A = DBLE(L) + B = DBLE(J) + C = DBLE(K) + AKA = ONE + IF (MOD(I1,2) /= 0) AKA = -AKA + IF (J - N == 3) THEN ! -3 - IF (K - M == 3) THEN + IF (K - M == 3) THEN ! I -3/2 -3/2 SI = AKA*DSQRT((AS - ONE)*AS*(AS + ONE)*(AS - A - TWO)*(AS - A - & ONE)*(AS - A)/((B - TWO)*(B - ONE)*B*(B + ONE)*(C - TWO)*(C - & - ONE)*C*(C + ONE))) - ELSE IF (M - K == 3) THEN + ONE)*C*(C + ONE))) + ELSE IF (M - K == 3) THEN ! IV P(12) 3/2 -3/2 SI = AKA*DSQRT((AS - C - TWO)*(AS - C - ONE)*(AS - C)*(AS - B + ONE& )*(AS - B + TWO)*(AS - B + THREE)/((C + 1)*(C + TWO)*(C + THREE)& - *(C + FOUR)*(B - TWO)*(B - ONE)*B*(B + ONE))) - ELSE IF (K - M == 1) THEN + *(C + FOUR)*(B - TWO)*(B - ONE)*B*(B + ONE))) + ELSE IF (K - M == 1) THEN ! II P(12) -1/2 -3/2 SI = AKA*DSQRT(THREE*AS*(AS + ONE)*(AS - A - ONE)*(AS - A)*(AS - C)& *(AS - B + ONE)/((C - ONE)*C*(C + ONE)*(C + TWO)*(B - TWO)*(B - & - ONE)*B*(B + ONE))) - ELSE IF (M - K == 1) THEN + ONE)*B*(B + ONE))) + ELSE IF (M - K == 1) THEN ! III P(12) 1/2 -3/2 SI = AKA*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - C - ONE)*(AS - C)*(& AS - B + ONE)*(AS - B + TWO)/(C*(C + ONE)*(C + TWO)*(C + THREE)*& - (B - TWO)*(B - ONE)*B*(B + ONE))) - ENDIF - ELSE IF (N - J == 3) THEN + (B - TWO)*(B - ONE)*B*(B + ONE))) + ENDIF + ELSE IF (N - J == 3) THEN ! 3 - IF (K - M == 3) THEN + IF (K - M == 3) THEN ! IV -3/2 3/2 SI = AKA*DSQRT((AS - B - TWO)*(AS - B - ONE)*(AS - B)*(AS - C + ONE& )*(AS - C + TWO)*(AS - C + THREE)/((B + ONE)*(B + TWO)*(B + & - THREE)*(B + FOUR)*(C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 3) THEN + THREE)*(B + FOUR)*(C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 3) THEN ! 2 pataisyta 3/2 3/2 SI = -AKA*DSQRT((AS + TWO)*(AS + THREE)*(AS + FOUR)*(AS - A + ONE)*& (AS - A + TWO)*(AS - A + THREE)/((B + ONE)*(B + TWO)*(B + THREE)& - *(B + FOUR)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) - ELSE IF (K - M == 1) THEN + *(B + FOUR)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) + ELSE IF (K - M == 1) THEN ! 1 P(12) pataisytas -1/2 3/2 SI = -AKA*DSQRT(THREE*(AS + TWO)*(AS - A + ONE)*(AS - C + ONE)*(AS& - C + TWO)*(AS - B - ONE)*(AS - B)/((C - ONE)*C*(C + ONE)*(C + & - TWO)*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) - ELSE IF (M - K == 1) THEN + TWO)*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) + ELSE IF (M - K == 1) THEN ! 3 P(12) taisyta 1/2 3/2 SI = AKA*DSQRT(THREE*(AS + TWO)*(AS + THREE)*(AS - A + ONE)*(AS - A& + TWO)*(AS - B)*(AS - C + ONE)/(C*(C + ONE)*(C + TWO)*(C + & - THREE)*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) - ENDIF + THREE)*(B + ONE)*(B + TWO)*(B + THREE)*(B + FOUR))) + ENDIF ! -1 - ELSE IF (J - N == 1) THEN - IF (K - M == 3) THEN + ELSE IF (J - N == 1) THEN + IF (K - M == 3) THEN ! II -3/2 -1/2 SI = AKA*DSQRT((THREE*AS*(AS + ONE)*(AS - A - ONE)*(AS - A)*(AS - B& )*(AS - C + ONE))/((B - ONE)*B*(B + ONE)*(B + TWO)*(C - TWO)*(C& - - ONE)*C*(C + ONE))) - ELSE IF (M - K == 3) THEN + - ONE)*C*(C + ONE))) + ELSE IF (M - K == 3) THEN ! 1 3/2 -1/2 SI = -AKA*DSQRT(THREE*(AS + TWO)*(AS - A + ONE)*(AS - B + ONE)*(AS& - B + TWO)*(AS - C - ONE)*(AS - C)/((B - ONE)*B*(B + ONE)*(B + & - TWO)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) - ELSE IF (K - M == 1) THEN + TWO)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) + ELSE IF (K - M == 1) THEN ! V -1/2 -1/2 SI = AKA*(TWO*(AS - B)*(AS - C) - (AS + TWO)*(AS - A - ONE))*DSQRT(& (AS + ONE)*(AS - A)/((B - ONE)*B*(B + ONE)*(B + TWO)*(C - ONE)*C& - *(C + ONE)*(C + TWO))) - ELSE IF (M - K == 1) THEN + *(C + ONE)*(C + TWO))) + ELSE IF (M - K == 1) THEN ! VI P(12) 1/2 -1/2 SI = AKA*((AS - B + TWO)*(AS - C + ONE) - TWO*(AS - A + ONE)*(AS + & ONE))*DSQRT((AS - C)*(AS - B + ONE)/(C*(C + ONE)*(C + TWO)*(C + & - THREE)*(B - ONE)*B*(B + ONE)*(B + TWO))) - ENDIF + THREE)*(B - ONE)*B*(B + ONE)*(B + TWO))) + ENDIF ! 1 - ELSE IF (N - J == 1) THEN - IF (K - M == 3) THEN + ELSE IF (N - J == 1) THEN + IF (K - M == 3) THEN ! III -3/2 1/2 SI = AKA*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - B - ONE)*(AS - B)*(& AS - C + ONE)*(AS - C + TWO)/(B*(B + ONE)*(B + TWO)*(B + THREE)*& - (C - TWO)*(C - ONE)*C*(C + ONE))) - ELSE IF (M - K == 3) THEN + (C - TWO)*(C - ONE)*C*(C + ONE))) + ELSE IF (M - K == 3) THEN ! 3 pataisyta 3/2 1/2 SI = AKA*DSQRT(THREE*(AS + TWO)*(AS + THREE)*(AS - A + ONE)*(AS - A& + TWO)*(AS - B + ONE)*(AS - C)/(B*(B + ONE)*(B + TWO)*(B + & - THREE)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) - ELSE IF (K - M == 1) THEN + THREE)*(C + ONE)*(C + TWO)*(C + THREE)*(C + FOUR))) + ELSE IF (K - M == 1) THEN ! VI -1/2 1/2 SI = AKA*((AS - C + TWO)*(AS - B + ONE) - TWO*(AS - A + ONE)*(AS + & ONE))*DSQRT((AS - B)*(AS - C + ONE)/(B*(B + ONE)*(B + TWO)*(B + & - THREE)*(C - ONE)*C*(C + ONE)*(C + TWO))) - ELSE IF (M - K == 1) THEN + THREE)*(C - ONE)*C*(C + ONE)*(C + TWO))) + ELSE IF (M - K == 1) THEN ! 4 pataisyta 1/2 1/2 SI = -AKA*(TWO*(AS - B)*(AS - C) - (AS + THREE)*(AS - A))*DSQRT((AS& + TWO)*(AS - A + ONE)/(B*(B + ONE)*(B + TWO)*(B + THREE)*C*(C& - + ONE)*(C + TWO)*(C + THREE))) - ENDIF - ENDIF - RETURN - END SUBROUTINE SIXJ35 + + ONE)*(C + TWO)*(C + THREE))) + ENDIF + ENDIF + RETURN + END SUBROUTINE SIXJ35 diff --git a/src/lib/librang90/sixj35_I.f90 b/src/lib/librang90/sixj35_I.f90 index a0b3870af..217f2c40a 100644 --- a/src/lib/librang90/sixj35_I.f90 +++ b/src/lib/librang90/sixj35_I.f90 @@ -1,6 +1,6 @@ MODULE sixj35_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj35 (J, K, L, M, N, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J diff --git a/src/lib/librang90/sixj3_I.f90 b/src/lib/librang90/sixj3_I.f90 index d5c425906..6e2e7fb12 100644 --- a/src/lib/librang90/sixj3_I.f90 +++ b/src/lib/librang90/sixj3_I.f90 @@ -1,6 +1,6 @@ MODULE sixj3_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj3 (J, K, L, M, N, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J @@ -10,7 +10,7 @@ SUBROUTINE sixj3 (J, K, L, M, N, ITIK, SI) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: ITIK REAL(DOUBLE), INTENT(OUT) :: SI -!VAST.../CONSTS/ ZERO(IN), ONE(IN), TWO(IN), THREE(IN), FOUR(IN) +!VAST.../CONSTS/ ZERO(IN), ONE(IN), TWO(IN), THREE(IN), FOUR(IN) !VAST.../CONSTS/ SEVEN(IN) !VAST...Calls: IXJTIK END SUBROUTINE diff --git a/src/lib/librang90/sixj4.f90 b/src/lib/librang90/sixj4.f90 index 5eb217402..298e734a6 100644 --- a/src/lib/librang90/sixj4.f90 +++ b/src/lib/librang90/sixj4.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ4(JC,JE,JD,JB,JF,ITIK,SI) + SUBROUTINE SIXJ4(JC,JE,JD,JB,JF,ITIK,SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -16,66 +16,66 @@ SUBROUTINE SIXJ4(JC,JE,JD,JB,JF,ITIK,SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, HALF, ONE, TWO, THREE, EPS !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I - USE dracah_I - USE sixj2_I - USE sixj3_I + USE ixjtik_I + USE dracah_I + USE sixj2_I + USE sixj3_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: JC, JE, JD, JB, JF - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - REAL(DOUBLE) :: A, C, E, D, B, F, X1, X2, X3, S2, S3 + REAL(DOUBLE) :: A, C, E, D, B, F, X1, X2, X3, S2, S3 !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(JC,JE,JD,JB,JF,8) == 0) RETURN - ENDIF - IF (IXJTIK(JC,JE,JD,JB,JF,6) == 0) THEN - CALL DRACAH (JC, JE, JF, JB, JD, 8, SI) - IF (MOD(JC + JE + JF + JB,4) /= 0) SI = -SI - ELSE - A = THREE - C = DBLE(JC)*HALF - E = DBLE(JE)*HALF - D = DBLE(JD)*HALF - B = DBLE(JB)*HALF - F = DBLE(JF)*HALF + IF (IXJTIK(JC,JE,JD,JB,JF,8) == 0) RETURN + ENDIF + IF (IXJTIK(JC,JE,JD,JB,JF,6) == 0) THEN + CALL DRACAH (JC, JE, JF, JB, JD, 8, SI) + IF (MOD(JC + JE + JF + JB,4) /= 0) SI = -SI + ELSE + A = THREE + C = DBLE(JC)*HALF + E = DBLE(JE)*HALF + D = DBLE(JD)*HALF + B = DBLE(JB)*HALF + F = DBLE(JF)*HALF X1 = A*DSQRT((A+B+E+TWO)*(A-B+E+ONE)*(A+B-E+ONE)*((- & A)+B+E)*(A+C+F+TWO)*(A-C+F+ONE)*(A+C-F+ONE)*( & - (-A)+C+F)) + (-A)+C+F)) X2 = (A+ONE)*DSQRT((A+B+E+ONE)*(A-B+E)*(A+B-E)*((-A) & + B+E+ONE)*(A+C+F+ONE)*(A-C+F)*(A+C-F)*((-A)+C & - + F+ONE)) + + F+ONE)) X3 = (TWO*A+ONE)*(TWO*(A*(A+ONE)*D*(D+ONE)-B*(B+ONE)*C*(C+ & ONE)-E*(E+ONE)*F*(F+ONE))+(A*(A+ONE)-B*(B+ONE)-E*(E & - +ONE))*(A*(A+ONE)-C*(C+ONE)-F*(F+ONE))) - IF (DABS(X2) < EPS) THEN - S2 = ZERO - ELSE - CALL SIXJ2 (JC, JE, JD, JB, JF, 0, S2) - ENDIF - IF (DABS(X3) < EPS) THEN - S3 = ZERO - ELSE - CALL SIXJ3 (JC, JE, JD, JB, JF, 0, S3) - ENDIF - SI = (X3*S3 - X2*S2)/X1 - ENDIF - RETURN - END SUBROUTINE SIXJ4 + +ONE))*(A*(A+ONE)-C*(C+ONE)-F*(F+ONE))) + IF (DABS(X2) < EPS) THEN + S2 = ZERO + ELSE + CALL SIXJ2 (JC, JE, JD, JB, JF, 0, S2) + ENDIF + IF (DABS(X3) < EPS) THEN + S3 = ZERO + ELSE + CALL SIXJ3 (JC, JE, JD, JB, JF, 0, S3) + ENDIF + SI = (X3*S3 - X2*S2)/X1 + ENDIF + RETURN + END SUBROUTINE SIXJ4 diff --git a/src/lib/librang90/sixj4_I.f90 b/src/lib/librang90/sixj4_I.f90 index 5bf72dcc4..0e0cb2dad 100644 --- a/src/lib/librang90/sixj4_I.f90 +++ b/src/lib/librang90/sixj4_I.f90 @@ -1,6 +1,6 @@ MODULE sixj4_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj4 (JC, JE, JD, JB, JF, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: JC diff --git a/src/lib/librang90/sixj5.f90 b/src/lib/librang90/sixj5.f90 index 5fb7855be..869e80740 100644 --- a/src/lib/librang90/sixj5.f90 +++ b/src/lib/librang90/sixj5.f90 @@ -1,6 +1,6 @@ !******************************************************************* ! * - SUBROUTINE SIXJ5(J,K,L,M,N,ITIK,SI) + SUBROUTINE SIXJ5(J,K,L,M,N,ITIK,SI) ! * ! THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT * ! * @@ -15,60 +15,60 @@ SUBROUTINE SIXJ5(J,K,L,M,N,ITIK,SI) !******************************************************************* ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE CONS_C, ONLY: ZERO, ONE, TWO !----------------------------------------------- ! I n t e r f a c e B l o c k s !----------------------------------------------- - USE ixjtik_I + USE ixjtik_I IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- INTEGER :: J, K, L, M, N - INTEGER, INTENT(IN) :: ITIK - REAL(DOUBLE), INTENT(OUT) :: SI + INTEGER, INTENT(IN) :: ITIK + REAL(DOUBLE), INTENT(OUT) :: SI !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: I1 - REAL(DOUBLE) :: AS, A, B, C, AKA + INTEGER :: I1 + REAL(DOUBLE) :: AS, A, B, C, AKA !----------------------------------------------- - SI = ZERO - IF (ITIK /= 0) THEN + SI = ZERO + IF (ITIK /= 0) THEN ! ! CHESKED TRIANGULAR CONDITIONS ! - IF (IXJTIK(J,K,L,M,N,1) == 0) RETURN - ENDIF - I1 = (J + K + L)/2 - AS = DBLE(I1) - A = DBLE(L) - B = DBLE(K) - C = DBLE(J) - AKA = ONE - IF (MOD(I1,2) /= 0) AKA = -AKA - IF (K < M) THEN - IF (J < N) THEN + IF (IXJTIK(J,K,L,M,N,1) == 0) RETURN + ENDIF + I1 = (J + K + L)/2 + AS = DBLE(I1) + A = DBLE(L) + B = DBLE(K) + C = DBLE(J) + AKA = ONE + IF (MOD(I1,2) /= 0) AKA = -AKA + IF (K < M) THEN + IF (J < N) THEN ! M > K, J < N. SI = -AKA*DSQRT((AS + TWO)*(AS - A + ONE)/((B + ONE)*(B + TWO)*(C& - + ONE)*(C + TWO))) - ELSE IF (J > N) THEN + + ONE)*(C + TWO))) + ELSE IF (J > N) THEN ! M > K, J > N. SI = AKA*DSQRT((AS - C + ONE)*(AS - B)/((B + ONE)*(B + TWO)*C*(C + & - ONE))) - ENDIF - ELSE IF (K > M) THEN - IF (J < N) THEN + ONE))) + ENDIF + ELSE IF (K > M) THEN + IF (J < N) THEN ! M < K, J < N. SI = AKA*DSQRT((AS - C)*(AS - B + ONE)/(B*(B + ONE)*(C + ONE)*(C + & - TWO))) - ELSE IF (J > N) THEN + TWO))) + ELSE IF (J > N) THEN ! M < K, J > N. - SI = AKA*DSQRT((AS + ONE)*(AS - A)/(B*(B + ONE)*C*(C + ONE))) - ENDIF - ENDIF - RETURN - END SUBROUTINE SIXJ5 + SI = AKA*DSQRT((AS + ONE)*(AS - A)/(B*(B + ONE)*C*(C + ONE))) + ENDIF + ENDIF + RETURN + END SUBROUTINE SIXJ5 diff --git a/src/lib/librang90/sixj5_I.f90 b/src/lib/librang90/sixj5_I.f90 index cddeda8a0..5d35072cb 100644 --- a/src/lib/librang90/sixj5_I.f90 +++ b/src/lib/librang90/sixj5_I.f90 @@ -1,6 +1,6 @@ MODULE sixj5_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:06:26 11/16/01 SUBROUTINE sixj5 (J, K, L, M, N, ITIK, SI) USE vast_kind_param,ONLY: DOUBLE INTEGER, INTENT(IN) :: J diff --git a/src/lib/librang90/snrc.f90 b/src/lib/librang90/snrc.f90 index 5b3248d85..d2da06d29 100644 --- a/src/lib/librang90/snrc.f90 +++ b/src/lib/librang90/snrc.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) ! * ! Determines the range of tensor rank NU for direct/exchange terms, * ! and classifies the types of radial integral. * @@ -22,100 +22,100 @@ SUBROUTINE SNRC(IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) ! Last update: 09 Oct 1992 * ! * !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- IMPLICIT NONE !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(OUT) :: ND1 - INTEGER, INTENT(OUT) :: ND2 - INTEGER, INTENT(OUT) :: NE1 - INTEGER, INTENT(OUT) :: NE2 - INTEGER, INTENT(OUT) :: IBRD - INTEGER, INTENT(OUT) :: IBRE - INTEGER, INTENT(IN) :: IS(4) - INTEGER, INTENT(IN) :: KAPS(4) - INTEGER, INTENT(IN) :: KS(4) + INTEGER, INTENT(OUT) :: ND1 + INTEGER, INTENT(OUT) :: ND2 + INTEGER, INTENT(OUT) :: NE1 + INTEGER, INTENT(OUT) :: NE2 + INTEGER, INTENT(OUT) :: IBRD + INTEGER, INTENT(OUT) :: IBRE + INTEGER, INTENT(IN) :: IS(4) + INTEGER, INTENT(IN) :: KAPS(4) + INTEGER, INTENT(IN) :: KS(4) !---------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: IAC, IAD, ND1A, ND2A, NE1A, NE2A + INTEGER :: IAC, IAD, ND1A, ND2A, NE1A, NE2A !----------------------------------------------- ! - ND2 = 0 - NE2 = 0 + ND2 = 0 + NE2 = 0 ! ! 2.0 Form limits for direct terms ! - IAC = 1 - IF (KAPS(1)*KAPS(3) < 0) IAC = -1 - IAD = 1 - IF (KAPS(2)*KAPS(4) < 0) IAD = -1 - ND1 = ABS(KS(1)-KS(3))/2 - 1 - IF (IAC == (-1)) ND1 = ND1 + 1 - IF (ND1 == (-1)) ND1 = 1 - ND1A = ABS(KS(2)-KS(4))/2 - 1 - IF (IAD == (-1)) ND1A = ND1A + 1 - IF (ND1A == (-1)) ND1A = 1 - IF (MOD(ND1 - ND1A,2) /= 0) THEN - IBRD = -1 - ELSE - ND2 = ABS(KS(1)+KS(3))/2 - IF (IAC == (-1)) ND2 = ND2 + 1 - ND2A = ABS(KS(2)+KS(4))/2 - IF (IAD == (-1)) ND2A = ND2A + 1 - ND1 = MAX(ND1,ND1A) - ND2 = MIN(ND2,ND2A) - ND2 = (ND2 - ND1)/2 + 1 + IAC = 1 + IF (KAPS(1)*KAPS(3) < 0) IAC = -1 + IAD = 1 + IF (KAPS(2)*KAPS(4) < 0) IAD = -1 + ND1 = ABS(KS(1)-KS(3))/2 - 1 + IF (IAC == (-1)) ND1 = ND1 + 1 + IF (ND1 == (-1)) ND1 = 1 + ND1A = ABS(KS(2)-KS(4))/2 - 1 + IF (IAD == (-1)) ND1A = ND1A + 1 + IF (ND1A == (-1)) ND1A = 1 + IF (MOD(ND1 - ND1A,2) /= 0) THEN + IBRD = -1 + ELSE + ND2 = ABS(KS(1)+KS(3))/2 + IF (IAC == (-1)) ND2 = ND2 + 1 + ND2A = ABS(KS(2)+KS(4))/2 + IF (IAD == (-1)) ND2A = ND2A + 1 + ND1 = MAX(ND1,ND1A) + ND2 = MIN(ND2,ND2A) + ND2 = (ND2 - ND1)/2 + 1 ! ! 2.1 Identify type of radial integrals ! - IBRD = 1 + IBRD = 1 IF (IS(1)==IS(3) .AND. IS(2)/=IS(4) .OR. IS(1)/=IS(3) .AND. IS(2)==IS(& - 4)) IBRD = 2 - IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRD = 3 - ENDIF + 4)) IBRD = 2 + IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRD = 3 + ENDIF ! ! 3.0 Form limits for exchange terms ! - IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) THEN - IBRE = -1 - RETURN - ENDIF - IAC = 1 - IF (KAPS(1)*KAPS(4) < 0) IAC = -1 - IAD = 1 - IF (KAPS(2)*KAPS(3) < 0) IAD = -1 - NE1 = IABS(KS(1)-KS(4))/2 - 1 - IF (IAC == (-1)) NE1 = NE1 + 1 - IF (NE1 == (-1)) NE1 = 1 - NE1A = ABS(KS(2)-KS(3))/2 - 1 - IF (IAD == (-1)) NE1A = NE1A + 1 - IF (NE1A == (-1)) NE1A = 1 - IF (MOD(NE1 - NE1A,2) /= 0) THEN - IBRE = -1 - RETURN - ENDIF + IF (IS(1)==IS(2) .OR. IS(3)==IS(4)) THEN + IBRE = -1 + RETURN + ENDIF + IAC = 1 + IF (KAPS(1)*KAPS(4) < 0) IAC = -1 + IAD = 1 + IF (KAPS(2)*KAPS(3) < 0) IAD = -1 + NE1 = IABS(KS(1)-KS(4))/2 - 1 + IF (IAC == (-1)) NE1 = NE1 + 1 + IF (NE1 == (-1)) NE1 = 1 + NE1A = ABS(KS(2)-KS(3))/2 - 1 + IF (IAD == (-1)) NE1A = NE1A + 1 + IF (NE1A == (-1)) NE1A = 1 + IF (MOD(NE1 - NE1A,2) /= 0) THEN + IBRE = -1 + RETURN + ENDIF ! - NE2 = ABS(KS(1)+KS(4))/2 - IF (IAC == (-1)) NE2 = NE2 + 1 - NE2A = ABS(KS(2)+KS(3))/2 - IF (IAD == (-1)) NE2A = NE2A + 1 - NE1 = MAX(NE1,NE1A) - NE2 = MIN(NE2,NE2A) - NE2 = (NE2 - NE1)/2 + 1 + NE2 = ABS(KS(1)+KS(4))/2 + IF (IAC == (-1)) NE2 = NE2 + 1 + NE2A = ABS(KS(2)+KS(3))/2 + IF (IAD == (-1)) NE2A = NE2A + 1 + NE1 = MAX(NE1,NE1A) + NE2 = MIN(NE2,NE2A) + NE2 = (NE2 - NE1)/2 + 1 ! ! 3.1 Identify type of radial integrals ! - IBRE = 1 + IBRE = 1 IF (IS(1)==IS(4) .AND. IS(2)/=IS(3) .OR. IS(1)/=IS(4) .AND. IS(2)==IS(3)& - ) IBRE = 2 - IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRE = 4 - RETURN + ) IBRE = 2 + IF (IS(1)==IS(3) .AND. IS(2)==IS(4)) IBRE = 4 + RETURN ! - END SUBROUTINE SNRC + END SUBROUTINE SNRC diff --git a/src/lib/librang90/snrc_I.f90 b/src/lib/librang90/snrc_I.f90 index a81879dae..c1ea15e2e 100644 --- a/src/lib/librang90/snrc_I.f90 +++ b/src/lib/librang90/snrc_I.f90 @@ -1,18 +1,18 @@ - MODULE snrc_I + MODULE snrc_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 06:33:54 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE snrc (IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) - INTEGER, DIMENSION(4), INTENT(IN) :: IS - INTEGER, DIMENSION(4), INTENT(IN) :: KAPS - INTEGER, DIMENSION(4), INTENT(IN) :: KS - INTEGER, INTENT(OUT) :: ND1 - INTEGER, INTENT(OUT) :: ND2 - INTEGER, INTENT(OUT) :: NE1 - INTEGER, INTENT(OUT) :: NE2 - INTEGER, INTENT(OUT) :: IBRD - INTEGER, INTENT(OUT) :: IBRE - END SUBROUTINE - END INTERFACE - END MODULE + SUBROUTINE snrc (IS, KAPS, KS, ND1, ND2, NE1, NE2, IBRD, IBRE) + INTEGER, DIMENSION(4), INTENT(IN) :: IS + INTEGER, DIMENSION(4), INTENT(IN) :: KAPS + INTEGER, DIMENSION(4), INTENT(IN) :: KS + INTEGER, INTENT(OUT) :: ND1 + INTEGER, INTENT(OUT) :: ND2 + INTEGER, INTENT(OUT) :: NE1 + INTEGER, INTENT(OUT) :: NE2 + INTEGER, INTENT(OUT) :: IBRD + INTEGER, INTENT(OUT) :: IBRE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/mpi90/cpath.f90 b/src/lib/mpi90/cpath.f90 index 8d89e8632..df81becea 100644 --- a/src/lib/mpi90/cpath.f90 +++ b/src/lib/mpi90/cpath.f90 @@ -5,8 +5,8 @@ subroutine cpath (startdir, permdir, tmpdir) ! permdir - path where node-0 performs serial i/o. ! tmpdir - path where the current node goes to. ! -! This version reads (by node-0) the paths from a disk file under the -! starting directory of the node-0, determine the length and do +! This version reads (by node-0) the paths from a disk file under the +! starting directory of the node-0, determine the length and do ! sending/receiving. Only if the paths defined here do not exist will ! C functions be called to create them. ! @@ -16,10 +16,10 @@ subroutine cpath (startdir, permdir, tmpdir) ! has/have to be created with call sys_mkdir ! Jacek Bieron 2017-10-31 ! -! cpath makes a sequence of attempts to create tmpdir directories +! cpath makes a sequence of attempts to create tmpdir directories ! at local disks of all nodes, in the following order: -! (1) 'disks' file -! (2) env variable MPI_TMP +! (1) 'disks' file +! (2) env variable MPI_TMP ! (3) directory /scratch/$USER ! if file 'disks' exists, cpath reads it ! if file 'disks' does not exist, cpath uses env variable MPI_TMP @@ -37,7 +37,7 @@ subroutine cpath (startdir, permdir, tmpdir) !cjb Jacek Bieron 2018 June 18 ! !*********************************************************************** -! +! !----------------------------------------------- ! M o d u l e s !----------------------------------------------- @@ -76,7 +76,7 @@ subroutine cpath (startdir, permdir, tmpdir) ! print *, ' in cpath myid = ', myid, ' startdir = ', startdir !======================================================================= -! Open disks file, read paths and send/receive them. Each node will have +! Open disks file, read paths and send/receive them. Each node will have ! its preliminary path stored in variable disk. In addition, node-0 will ! have the current working directory stored in permdir !======================================================================= @@ -91,14 +91,14 @@ subroutine cpath (startdir, permdir, tmpdir) open (unit=1001, file='disks', status='old') !...paths for serial i/o, node-0 only read (1001,*) permdir ! paths for serial i/o, node-0 only - read (1001,*) tmpdir ! temporary for local disk of node-0 - !...paths for slaves, read and send; + read (1001,*) tmpdir ! temporary for local disk of node-0 + !...paths for slaves, read and send; do i = 1, nprocs - 1 read (1001,*) disk call MPI_Send (disk, lendisk0, MPI_CHARACTER, i, i, & MPI_COMM_WORLD, ierr2m) enddo - disk = tmpdir ! local disk of node-0 + disk = tmpdir ! local disk of node-0 close (1001) else permdir = startdir @@ -159,7 +159,7 @@ subroutine cpath (startdir, permdir, tmpdir) !======================================================================= ! step 08 MPI_Send/MPI_Recv tmpdir !======================================================================= - tmpdir = mpi_tmp(1:lstring) + tmpdir = mpi_tmp(1:lstring) disk = tmpdir(1:lstring) do i = 1, nprocs - 1 call MPI_Send (disk, lendisk0, MPI_CHARACTER, i, i, & @@ -186,16 +186,16 @@ subroutine cpath (startdir, permdir, tmpdir) ! ! sequentially call sys_mkdir (to avoid simultaneous sys_mkdir) !======================================================================= -! +! !======================================================================= -! step 14 mkdir tmpdir +! step 14 mkdir tmpdir !======================================================================= ! call sys_chdir (disk, lendisk, ierr) ! print *, ' in cpath myid = ', myid, ' disk = ', disk if (ierr.ne.0) call sys_mkdir (disk, lendisk, ierr) if (ierr.ne.0) then -! error141 failed to mkdir tmpdir +! error141 failed to mkdir tmpdir ! step14 try mkdir twice more do itry = 1, 2 ! get some sleep -- different loop times depending on myid @@ -219,7 +219,7 @@ subroutine cpath (startdir, permdir, tmpdir) enddo ! if (ierr.ne.0) call exit(1) if (ierr .ne. 0) then -! +! ! error141 failed to mkdir tmpdir print *, ' error141 cpath failed at sys_mkdir(disk), myid = ',& myid @@ -231,12 +231,12 @@ subroutine cpath (startdir, permdir, tmpdir) endif ! !======================================================================= -! step 16 cd tmpdir +! step 16 cd tmpdir !======================================================================= ! call sys_chdir (disk, lendisk, ierr) if (ierr .ne. 0) then -! error161 failed to chdir tmpdir +! error161 failed to chdir tmpdir ! step16 try chdir twice more do itry = 1, 2 ! get some sleep -- different loop times depending on myid @@ -260,8 +260,8 @@ subroutine cpath (startdir, permdir, tmpdir) enddo ! if (ierr.ne.0) call exit(1) if (ierr .ne. 0) then -! -! error161 failed to chdir tmpdir +! +! error161 failed to chdir tmpdir print *, ' error161 cpath failed at sys_chdir(disk); myid = ',& myid ! stop @@ -290,7 +290,7 @@ subroutine cpath (startdir, permdir, tmpdir) ! stop goto 999 endif - call sys_chdir (idstring, lenidstring, ierr) + call sys_chdir (idstring, lenidstring, ierr) if (ierr .ne. 0) then ! ! error183 failed to chdir tmpdir/myid @@ -316,7 +316,7 @@ subroutine cpath (startdir, permdir, tmpdir) MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr2m) ! step20 ierr_all_nodes ! if (myid .eq. 0) then -! print *, ' step20 cpath ierr_all_nodes = ', ierr_all_nodes, & +! print *, ' step20 cpath ierr_all_nodes = ', ierr_all_nodes, & ! ' myid = ', myid ! endif ! @@ -337,7 +337,7 @@ subroutine cpath (startdir, permdir, tmpdir) endif !======================================================================= -! step 2222 all nodes succeeded +! step 2222 all nodes succeeded ! cpath succeeded !======================================================================= diff --git a/src/lib/mpi90/cpath_I.f90 b/src/lib/mpi90/cpath_I.f90 index 46d15d7fd..8e13f8fbe 100644 --- a/src/lib/mpi90/cpath_I.f90 +++ b/src/lib/mpi90/cpath_I.f90 @@ -3,7 +3,7 @@ MODULE cpath_I ! SUBROUTINE CPATH(startdir, permdir, tmpdir) ! USE vast_kind_param, ONLY: DOUBLE -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 CHARACTER(len=*), INTENT(IN) :: startdir, permdir, tmpdir END SUBROUTINE diff --git a/src/lib/mpi90/cslhmpi.f90 b/src/lib/mpi90/cslhmpi.f90 index c3024153f..ef8512f3a 100644 --- a/src/lib/mpi90/cslhmpi.f90 +++ b/src/lib/mpi90/cslhmpi.f90 @@ -2,8 +2,8 @@ ! SUBROUTINE CSLHMPI(NAME, NCORE, NBLKIN, IDBLK) ! -! A container which calls setcsll to open, read file to get -! nblock, ncfblk(), idblk(), ncftot. +! A container which calls setcsll to open, read file to get +! nblock, ncfblk(), idblk(), ncftot. ! It then calls lib92/lodcsh to get ! ncore, nelec, nw, np(), nak(), nkl(), nkj(), nh() ! The file pointer points to the first CSL record after this routine. @@ -13,11 +13,11 @@ SUBROUTINE CSLHMPI(NAME, NCORE, NBLKIN, IDBLK) ! Xinghong He 98-06-23 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE memory_man use mpi_C diff --git a/src/lib/mpi90/cslhmpi_I.f90 b/src/lib/mpi90/cslhmpi_I.f90 index b9c156746..d108ec04c 100644 --- a/src/lib/mpi90/cslhmpi_I.f90 +++ b/src/lib/mpi90/cslhmpi_I.f90 @@ -2,7 +2,7 @@ MODULE cslhmpi_I INTERFACE ! SUBROUTINE cslhmpi (NAME, NCORE, NBLKIN, IDBLK) -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 CHARACTER (LEN = *) :: NAME INTEGER :: NCORE diff --git a/src/lib/mpi90/iniestmpi.f90 b/src/lib/mpi90/iniestmpi.f90 index ddc7c9ac7..05b04f5d3 100644 --- a/src/lib/mpi90/iniestmpi.f90 +++ b/src/lib/mpi90/iniestmpi.f90 @@ -1,14 +1,14 @@ !*********************************************************************** ! - SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) + SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) ! -! Routine for providing initial estimates from the diagonal -! of the matrix. This way was used by Dvdson in atomic structure -! calculations. It should be used to obtain estimates when nothing +! Routine for providing initial estimates from the diagonal +! of the matrix. This way was used by Dvdson in atomic structure +! calculations. It should be used to obtain estimates when nothing ! else is available. ! ! nmax is typically 1000 - + ! Structure of the input sparse matrix hmx: ! . It's a 1-d array ! . Length: 1 to jcol(ncf) @@ -18,13 +18,13 @@ SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) ! Xinghong He 98-10-28 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 12:36:59 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE memory_man use mpi_C @@ -32,20 +32,20 @@ SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) !----------------------------------------------- ! D u m m y A r g u m e n t s !----------------------------------------------- - INTEGER, INTENT(IN) :: NMAX - INTEGER, INTENT(IN) :: NCF - INTEGER :: NIV - INTEGER, INTENT(IN) :: JCOL(0:*) - INTEGER, INTENT(IN) :: IROW(*) - real(double) :: BASIS(*) - real(double), INTENT(IN) :: HMX(*) + INTEGER, INTENT(IN) :: NMAX + INTEGER, INTENT(IN) :: NCF + INTEGER :: NIV + INTEGER, INTENT(IN) :: JCOL(0:*) + INTEGER, INTENT(IN) :: IROW(*) + real(double) :: BASIS(*) + real(double), INTENT(IN) :: HMX(*) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: NS, JOFFSPAR, J, JOFFNORM, IR, NFOUND, INFO - integer, dimension(:), pointer :: iwork,ifail - real(double), dimension(:), pointer :: ap, eigval,vec, work + integer, dimension(:), pointer :: iwork,ifail + real(double), dimension(:), pointer :: ap, eigval,vec, work real(double) :: ABSTOL REAL(KIND(0.0D0)) :: dlamch @@ -54,24 +54,24 @@ SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) !----------------------------------------------- - NS = MIN(NMAX,NCF) + NS = MIN(NMAX,NCF) CALL ALLOC (AP, (NS*(NS + 1))/2, 'AP', 'INIESTmpi') - CALL DINIT ((NS*(NS + 1))/2, 0.D0, AP, 1) - + CALL DINIT ((NS*(NS + 1))/2, 0.D0, AP, 1) + ! Expand the sparse form to normal form for upper-right sub-matrix - - JOFFSPAR = 0 ! offset for sparse form -! DO J = 1, NS + + JOFFSPAR = 0 ! offset for sparse form +! DO J = 1, NS DO j = myid + 1, ns, nprocs - JOFFNORM = (J*(J - 1))/2 ! offset for normal form - DO IR = JOFFSPAR + 1, JCOL(J) - AP(IROW(IR)+JOFFNORM) = HMX(IR) - END DO - JOFFSPAR = JCOL(J) - END DO - + JOFFNORM = (J*(J - 1))/2 ! offset for normal form + DO IR = JOFFSPAR + 1, JCOL(J) + AP(IROW(IR)+JOFFNORM) = HMX(IR) + END DO + JOFFSPAR = JCOL(J) + END DO + ! Merge ap from all nodes and then send to all nodes - + CALL gdsummpi (ap, (NS*(NS+1))/2) CALL ALLOC(eigval, ns, 'EIGVAL', 'INIESTmpi') @@ -80,32 +80,32 @@ SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) !GG CALL ALLOC (iwork, 8*ns, 'IWORK', 'INIESTmpi') CALL ALLOC (iwork, 5*ns, 'IWORK', 'INIESTmpi') CALL ALLOC (ifail, ns, 'IFAIL', 'INIESTmpi') - + ABSTOL = 2*dLAMCH('S') CALL DSPEVX ('Vectors also', 'In a range', 'Upper triangular', NS, AP, & -1., -1., 1, NIV, ABSTOL, NFOUND, EIGVAL, VEC, NS, WORK, IWORK, IFAIL, & - INFO) - IERR = -ABS(INFO) - + INFO) + IERR = -ABS(INFO) + ! Build the Basis. - - CALL DINIT (NCF*NIV, 0.D0, BASIS, 1) - + + CALL DINIT (NCF*NIV, 0.D0, BASIS, 1) + ! scatter the vectors - - DO J = 1, NIV - CALL DCOPY (NS, VEC(NS*(J-1)+1), 1, BASIS(NCF*(J-1)+1), 1) - END DO - - CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*NCF+1), 1) - + + DO J = 1, NIV + CALL DCOPY (NS, VEC(NS*(J-1)+1), 1, BASIS(NCF*(J-1)+1), 1) + END DO + + CALL DCOPY (NIV, EIGVAL, 1, BASIS(NIV*NCF+1), 1) + CALL DALLOC (ap, 'AP', 'INIESTmpi') CALL DALLOC (eigval, 'EIGVAL', 'INIESTmpi') CALL DALLOC (vec, 'VEC', 'INIESTmpi') CALL DALLOC (work, 'WORK', 'INIESTmpi') CALL DALLOC (iwork, 'IWORK', 'INIESTmpi') CALL DALLOC (ifail, 'IFAIL', 'INIESTmpi') - - RETURN + + RETURN END SUBROUTINE INIESTmpi diff --git a/src/lib/mpi90/iniestmpi_I.f90 b/src/lib/mpi90/iniestmpi_I.f90 index dc4642b9c..4396595a0 100644 --- a/src/lib/mpi90/iniestmpi_I.f90 +++ b/src/lib/mpi90/iniestmpi_I.f90 @@ -1,7 +1,7 @@ MODULE INIESTmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE INIESTmpi (NMAX, NCF, NIV, BASIS, HMX, JCOL, IROW) USE vast_kind_param, ONLY: DOUBLE diff --git a/src/lib/mpi90/lodcslmpi.f90 b/src/lib/mpi90/lodcslmpi.f90 index 09744022f..766632a23 100644 --- a/src/lib/mpi90/lodcslmpi.f90 +++ b/src/lib/mpi90/lodcslmpi.f90 @@ -1,29 +1,29 @@ !*********************************************************************** SUBROUTINE lodcslmpi (nfile, ncore, jblock) -! An MPI container of lodcsh2 which loads CSL list of the current block -! into memory. It forwards the call together with the same set of +! An MPI container of lodcsh2 which loads CSL list of the current block +! into memory. It forwards the call together with the same set of ! parameters to lodcsh2 and then broadcasts the results to all nodes. ! ! Note: Memories have been allocated/deallocated each block outside. -! This subroutine calls lodcsh2 on node-0 to generate the data for the +! This subroutine calls lodcsh2 on node-0 to generate the data for the ! block; and then broadcasts to all other nodes. A new MPI data type ! of 4 byte-long is created to handle 64-bit machines whose MPI ! implementation does not support 4-byte integers. If jblock=-119, -! then ALL blocks will be loaded instead of just one. This is +! then ALL blocks will be loaded instead of just one. This is ! implemented in lodcsh2. ! -! Currently used by rcimpivu, mcpmpi, rscfmpivu +! Currently used by rcimpivu, mcpmpi, rscfmpivu ! ! Xinghong He 98-08-06 ! !*********************************************************************** -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: BYTE USE parameter_def, ONLY: NNNW diff --git a/src/lib/mpi90/lodcslmpi_I.f90 b/src/lib/mpi90/lodcslmpi_I.f90 index 77d2886b2..2e9eb54ac 100644 --- a/src/lib/mpi90/lodcslmpi_I.f90 +++ b/src/lib/mpi90/lodcslmpi_I.f90 @@ -1,7 +1,7 @@ MODULE lodcslmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE lodcslmpi (nfile, ncore, jblock) INTEGER :: nfile, ncore, jblock diff --git a/src/lib/mpi90/lodrwfmpi.f90 b/src/lib/mpi90/lodrwfmpi.f90 index 98b8196dc..5eb9f9d83 100644 --- a/src/lib/mpi90/lodrwfmpi.f90 +++ b/src/lib/mpi90/lodrwfmpi.f90 @@ -16,11 +16,11 @@ SUBROUTINE LODRWFmpi (ierror) ! MPI version by Xinghong He Last revision: 27 May 1997 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNP diff --git a/src/lib/mpi90/lodrwfmpi_I.f90 b/src/lib/mpi90/lodrwfmpi_I.f90 index d179ef573..c95a44d02 100644 --- a/src/lib/mpi90/lodrwfmpi_I.f90 +++ b/src/lib/mpi90/lodrwfmpi_I.f90 @@ -1,6 +1,6 @@ MODULE LODRWFmpi_I INTERFACE -!...Modified by Charlotte Froese Fischer +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE LODRWFmpi (ierror) INTEGER , INTENT(OUT) :: ierror diff --git a/src/lib/mpi90/mpi_C.f90 b/src/lib/mpi90/mpi_C.f90 index edd57fecc..a60e47f64 100644 --- a/src/lib/mpi90/mpi_C.f90 +++ b/src/lib/mpi90/mpi_C.f90 @@ -1,20 +1,20 @@ - MODULE mpi_C - USE vast_kind_param, ONLY: DOUBLE -!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 -!...Modified by Charlotte Froese Fischer + MODULE mpi_C + USE vast_kind_param, ONLY: DOUBLE +!...Created by Pacific-Sierra Research 77to90 4.3E 06:23:52 12/28/06 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !cjb ! "INCLUDE mpif.h" is going to be deprecated in future MPI releases ! and "USE mpi" is recommended ! if you already have an MPI library with precompiled mpi.mod -! we recommend to uncomment version "USE mpi" below +! we recommend to uncomment version "USE mpi" below ! and comment out version 'mpif.h' ! depending on your environment ! it may be necessary to add $(MPI_INC) = -I/path in Makefile ! grasp/src/lib/mpi90/Makefile ! with 'path' pointing to module 'mpi.mod' !cjb -! otherwise uncomment 'mpif.h' and comment out "USE mpi" +! otherwise uncomment 'mpif.h' and comment out "USE mpi" ! do not uncomment both !cjb diff --git a/src/lib/mpi90/mpiu.f90 b/src/lib/mpi90/mpiu.f90 index 2b72462b2..c98f076af 100644 --- a/src/lib/mpi90/mpiu.f90 +++ b/src/lib/mpi90/mpiu.f90 @@ -247,12 +247,12 @@ subroutine mpix_printmsg (msg, myid, nprocs) CHARACTER(LEN=*), INTENT(OUT) :: msg !----------------------------------------------- -! L o c a l V a r i a b l e s +! L o c a l V a r i a b l e s !----------------------------------------------- INTEGER :: inID, istat(MPI_STATUS_SIZE), ierr, msgLength msgLength = len_trim (msg) - + if (myid .ne. 0) then call MPI_Send (msgLength, 1, MPI_INTEGER, 0, myid, & MPI_COMM_WORLD, ierr) ! Send nsgLength @@ -310,7 +310,7 @@ subroutine mpix_bytes (n, newType, ierr) !----------------------------------------------- IMPLICIT NONE include 'mpif.h' - INTEGER, INTENT(IN) :: n + INTEGER, INTENT(IN) :: n INTEGER, INTENT(out) :: newtype, ierr !----------------------------------------------- ! L o c a l V a r i a b l e s @@ -368,4 +368,4 @@ SUBROUTINE gisummpi (ix, n) CALL icopy (n, iy, 1, ix, 1) RETURN - END + END diff --git a/src/lib/mpi90/setisompi.f90 b/src/lib/mpi90/setisompi.f90 index 375737e2a..db25b7d71 100644 --- a/src/lib/mpi90/setisompi.f90 +++ b/src/lib/mpi90/setisompi.f90 @@ -9,11 +9,11 @@ SUBROUTINE setisompi (isofile) ! Xinghong He 98-08-06 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE MPI_C USE DEF_C diff --git a/src/lib/mpi90/setisompi_I.f90 b/src/lib/mpi90/setisompi_I.f90 index d5d891e39..cc836b3f3 100644 --- a/src/lib/mpi90/setisompi_I.f90 +++ b/src/lib/mpi90/setisompi_I.f90 @@ -1,7 +1,7 @@ MODULE setisompi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE setisompi (isofile) CHARACTER*(*) isofile diff --git a/src/lib/mpi90/setrwfmpi.f90 b/src/lib/mpi90/setrwfmpi.f90 index 27e99361a..28dd6509c 100644 --- a/src/lib/mpi90/setrwfmpi.f90 +++ b/src/lib/mpi90/setrwfmpi.f90 @@ -11,11 +11,11 @@ SUBROUTINE SETRWFmpi (NAME) ! MPI version by Xinghong He Last revision: 06 Aug 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE mpi_C USE iounit_C @@ -35,7 +35,7 @@ SUBROUTINE SETRWFmpi (NAME) INTEGER :: IOS, IERROR CHARACTER (LEN = 6) :: G92RWF !----------------------------------------------- - IF (myid .EQ. 0) THEN + IF (myid .EQ. 0) THEN CALL openfl (23, name, 'UNFORMATTED', 'OLD', ierror) IF (ierror .EQ. 1) THEN WRITE (istde,*) 'Error opening', name(1:LEN_TRIM (name)) diff --git a/src/lib/mpi90/setrwfmpi_I.f90 b/src/lib/mpi90/setrwfmpi_I.f90 index 59829b0cc..71872ee47 100644 --- a/src/lib/mpi90/setrwfmpi_I.f90 +++ b/src/lib/mpi90/setrwfmpi_I.f90 @@ -1,7 +1,7 @@ MODULE SETRWFmpi_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SETRWFmpi (NAME) CHARACTER NAME*(*) diff --git a/src/lib/mpi90/spicmvmpi.f90 b/src/lib/mpi90/spicmvmpi.f90 index d65b224b0..48774b6b5 100644 --- a/src/lib/mpi90/spicmvmpi.f90 +++ b/src/lib/mpi90/spicmvmpi.f90 @@ -21,11 +21,11 @@ SUBROUTINE SPICMVmpi (N,M,B,C) ! MPI version by Xinghong He Last revision: 29 Jul 1998 * ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- USE vast_kind_param, ONLY: DOUBLE USE mpi_C diff --git a/src/lib/mpi90/spicmvmpi_I.f90 b/src/lib/mpi90/spicmvmpi_I.f90 index 8a8f894c9..ee456747a 100644 --- a/src/lib/mpi90/spicmvmpi_I.f90 +++ b/src/lib/mpi90/spicmvmpi_I.f90 @@ -1,15 +1,15 @@ MODULE spicmvmpi_I INTERFACE -!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:46 2/14/04 -!...Modified by Charlotte Froese Fischer +!...Generated by Pacific-Sierra Research 77to90 4.3E 10:50:46 2/14/04 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 - SUBROUTINE spicmvmpi (N, M, B, C) - USE vast_kind_param, ONLY: DOUBLE - INTEGER, INTENT(IN) :: N - INTEGER, INTENT(IN) :: M - REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B - REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C + SUBROUTINE spicmvmpi (N, M, B, C) + USE vast_kind_param, ONLY: DOUBLE + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(IN) :: M + REAL(DOUBLE), DIMENSION(N,M), INTENT(IN) :: B + REAL(DOUBLE), DIMENSION(N,M), INTENT(INOUT) :: C !VAST...Calls: DINIT, IENDC, EMT, IROW, DMERGE - END SUBROUTINE - END INTERFACE - END MODULE + END SUBROUTINE + END INTERFACE + END MODULE diff --git a/src/lib/mpi90/sys_chdir.f90 b/src/lib/mpi90/sys_chdir.f90 index 100fc16c2..19ba5e4aa 100644 --- a/src/lib/mpi90/sys_chdir.f90 +++ b/src/lib/mpi90/sys_chdir.f90 @@ -2,17 +2,17 @@ subroutine sys_chdir (dir, lendir, ierr) ! ! This routine changes current working directory to dir. -! lendir is the length of character string dir; +! lendir is the length of character string dir; ! ierr will be zero if successful, otherwise non-zero; ! ! Xinghong He 98-08-21 ! -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- implicit none character(len=*), intent(in):: dir diff --git a/src/lib/mpi90/sys_chdir_I.f90 b/src/lib/mpi90/sys_chdir_I.f90 index 5f63d61e7..8cdfb8076 100644 --- a/src/lib/mpi90/sys_chdir_I.f90 +++ b/src/lib/mpi90/sys_chdir_I.f90 @@ -1,7 +1,7 @@ MODULE SYS_CHDIR_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SYS_CHDIR (dir, lendir, ierr) character(len=*), intent(in):: dir diff --git a/src/lib/mpi90/sys_getwd.f90 b/src/lib/mpi90/sys_getwd.f90 index c0df285f8..4cda8396b 100644 --- a/src/lib/mpi90/sys_getwd.f90 +++ b/src/lib/mpi90/sys_getwd.f90 @@ -8,12 +8,12 @@ subroutine sys_getwd (dir,lcwd) ! ! Xinghong He 98-08-24 ! -!************************************************************************ -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!************************************************************************ +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- use mpi_C diff --git a/src/lib/mpi90/sys_getwd_I.f90 b/src/lib/mpi90/sys_getwd_I.f90 index a60deac4b..0bb81d609 100644 --- a/src/lib/mpi90/sys_getwd_I.f90 +++ b/src/lib/mpi90/sys_getwd_I.f90 @@ -1,7 +1,7 @@ MODULE SYS_GETWD_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SYS_GETWD(dir,lcwd) character(len=*), intent(out):: dir diff --git a/src/lib/mpi90/sys_mkdir.f90 b/src/lib/mpi90/sys_mkdir.f90 index 646ce80ff..69459d757 100644 --- a/src/lib/mpi90/sys_mkdir.f90 +++ b/src/lib/mpi90/sys_mkdir.f90 @@ -2,22 +2,22 @@ subroutine sys_mkdir (dir, lendir, ierr) ! ! This routine makes a sub-dir under the current working directory. -! lendir is the length of character string dir; +! lendir is the length of character string dir; ! ierr will be zero if successful, otherwise non-zero; ! machine is an optional parameter specifying the name of the system ! ! Xinghong He 98-08-21 ! !*********************************************************************** -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 ! ! function 'system' and execute_command_line commented out !cjb Jacek Bieron 2018 June 18 ! !----------------------------------------------- -! M o d u l e s +! M o d u l e s !----------------------------------------------- ! use mpi_C !----------------------------------------------- @@ -39,7 +39,7 @@ subroutine sys_mkdir (dir, lendir, ierr) !cjb ! print*, dir(1:lendir) ! print*, dir(1:lendir) -! +! ierr = system ('mkdir -p -m 775 ' // dir(1:lendir)) !cjb use EXECUTE_COMMAND_LINE if function 'system' is not supported ! call execute_command_line ('mkdir -p -m 775 ' // dir(1:lendir), & diff --git a/src/lib/mpi90/sys_mkdir_I.f90 b/src/lib/mpi90/sys_mkdir_I.f90 index 355d0dd0a..5921c679d 100644 --- a/src/lib/mpi90/sys_mkdir_I.f90 +++ b/src/lib/mpi90/sys_mkdir_I.f90 @@ -1,7 +1,7 @@ MODULE SYS_MKDIR_I INTERFACE -!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 -!...Modified by Charlotte Froese Fischer +!...Translated by Pacific-Sierra Research 77to90 4.3E 14:04:58 1/ 3/07 +!...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 SUBROUTINE SYS_MKDIR(dir, lendir, ierr) character(len=*), intent(in):: dir diff --git a/src/tool/Makefile b/src/tool/Makefile index 9b3acff5b..04936da00 100644 --- a/src/tool/Makefile +++ b/src/tool/Makefile @@ -5,14 +5,14 @@ GRASPLIB = ${GRASP}/lib SRCLIBDIR = ../lib MODDIR = ${SRCLIBDIR}/libmod MODL9290 = ${SRCLIBDIR}/lib9290 -GRASPLIBS = -l9290 -lmod +GRASPLIBS = -l9290 -lmod APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} -llapack -lblas UTIL = rcsfsplit rmixaccumulate rseqenergy \ rseqhfs rseqtrans rtablevels rtabtransE1 \ -install: EXE +install: EXE cp rsave $(GRASP)/bin cp lscomp.pl $(GRASP)/bin @@ -38,43 +38,43 @@ EXE : $(BIN)/rcsfsplit \ $(BIN)/rwfnrelabel \ $(BIN)/rhfs_lsj \ $(BIN)/rcsfmr \ - + OBJ : rasfsplit.o rcsfsplit.o rmixaccumulate.o rseqenergy.o \ rseqhfs.o rseqtrans.o rtablevels.o rtabtransE1.o \ rmixextract.o rcsfblock.o rwfnmchfmcdf.o \ rlevels.o rtabtrans1.o format_mix.o rlevelsj.o \ rwfnrotate.o \ - rwfnplot.o rtabtrans2.o rlevelseV.o rtabhfs.o wfnplot.o rwfnrelabel.o \ + rwfnplot.o rtabtrans2.o rlevelseV.o rtabhfs.o wfnplot.o rwfnrelabel.o \ rhfs_lsj.o rcsfmr.o\ $(BIN)/rasfsplit: rasfsplit.o - $(FC) -o $(BIN)/rasfsplit rasfsplit.f90 + $(FC) -o $(BIN)/rasfsplit rasfsplit.f90 $(BIN)/rcsfsplit: rcsfsplit.o - $(FC) -o $(BIN)/rcsfsplit rcsfsplit.o + $(FC) -o $(BIN)/rcsfsplit rcsfsplit.o $(BIN)/rmixaccumulate: rmixaccumulate.o - $(FC) -o $(BIN)/rmixaccumulate rmixaccumulate.o + $(FC) -o $(BIN)/rmixaccumulate rmixaccumulate.o $(BIN)/rseqenergy: rseqenergy.o - $(FC) -o $(BIN)/rseqenergy rseqenergy.o + $(FC) -o $(BIN)/rseqenergy rseqenergy.o $(BIN)/rseqtrans: rseqtrans.o - $(FC) -o $(BIN)/rseqtrans rseqtrans.o + $(FC) -o $(BIN)/rseqtrans rseqtrans.o $(BIN)/rseqhfs: rseqhfs.o - $(FC) -o $(BIN)/rseqhfs rseqhfs.o + $(FC) -o $(BIN)/rseqhfs rseqhfs.o $(BIN)/rtablevels: rtablevels.o - $(FC) -o $(BIN)/rtablevels rtablevels.o + $(FC) -o $(BIN)/rtablevels rtablevels.o $(BIN)/rtabtransE1: rtabtransE1.o - $(FC) -o $(BIN)/rtabtransE1 rtabtransE1.o + $(FC) -o $(BIN)/rtabtransE1 rtabtransE1.o $(BIN)/format_mix : format_mix.o $(FC) -o $(BIN)/format_mix $(FC_LD) -L$(LIBDIR) \ - format_mix.o + format_mix.o $(BIN)/rmixextract: rmixextract.o $(FC) -o $(BIN)/rmixextract $(FC_LD) rmixextract.o $(APP_LIBS) @@ -83,37 +83,37 @@ $(BIN)/rcsfblock: rcsfblock.o $(FC) -o $(BIN)/rcsfblock $(FC_LD) rcsfblock.o $(APP_LIBS) $(BIN)/rwfnmchfmcdf: rwfnmchfmcdf.o - $(FC) -o $(BIN)/rwfnmchfmcdf $(FC_LD) rwfnmchfmcdf.o $(APP_LIBS) + $(FC) -o $(BIN)/rwfnmchfmcdf $(FC_LD) rwfnmchfmcdf.o $(APP_LIBS) $(BIN)/rlevels: rlevels.o $(FC) -o $(BIN)/rlevels $(FC_LD) rlevels.o $(APP_LIBS) $(BIN)/rtabtrans1: rtabtrans1.o - $(FC) -o $(BIN)/rtabtrans1 $(FC_LD) rtabtrans1.o $(APP_LIBS) + $(FC) -o $(BIN)/rtabtrans1 $(FC_LD) rtabtrans1.o $(APP_LIBS) $(BIN)/rlevelsj: rlevelsj.o - $(FC) -o $(BIN)/rlevelsj $(FC_LD) rlevelsj.o $(APP_LIBS) + $(FC) -o $(BIN)/rlevelsj $(FC_LD) rlevelsj.o $(APP_LIBS) $(BIN)/rwfnplot: rwfnplot.o - $(FC) -o $(BIN)/rwfnplot rwfnplot.o + $(FC) -o $(BIN)/rwfnplot rwfnplot.o $(BIN)/rtabtrans2: rtabtrans2.o - $(FC) -o $(BIN)/rtabtrans2 rtabtrans2.o + $(FC) -o $(BIN)/rtabtrans2 rtabtrans2.o $(BIN)/rlevelseV: rlevelseV.o - $(FC) -o $(BIN)/rlevelseV $(FC_LD) rlevelseV.o $(APP_LIBS) + $(FC) -o $(BIN)/rlevelseV $(FC_LD) rlevelseV.o $(APP_LIBS) $(BIN)/rtabhfs: rtabhfs.o - $(FC) -o $(BIN)/rtabhfs rtabhfs.o + $(FC) -o $(BIN)/rtabhfs rtabhfs.o $(BIN)/wfnplot: wfnplot.o - $(FC) -o $(BIN)/wfnplot wfnplot.o + $(FC) -o $(BIN)/wfnplot wfnplot.o $(BIN)/rwfnrotate: rwfnrotate.o - $(FC) -o $(BIN)/rwfnrotate $(FC_LD) rwfnrotate.o $(APP_LIBS) + $(FC) -o $(BIN)/rwfnrotate $(FC_LD) rwfnrotate.o $(APP_LIBS) $(BIN)/rwfnrelabel: rwfnrelabel.o - $(FC) -o $(BIN)/rwfnrelabel $(FC_LD) rwfnrelabel.o $(APP_LIBS) + $(FC) -o $(BIN)/rwfnrelabel $(FC_LD) rwfnrelabel.o $(APP_LIBS) $(BIN)/rhfs_lsj: rhfs_lsj.o $(FC) -o $(BIN)/rhfs_lsj $(FC_LD) rhfs_lsj.o $(APPS_LIBS) @@ -127,6 +127,3 @@ $(BIN)/rcsfmr: rcsfmr.o clean: -rm -f *.o core *.mod - - - diff --git a/src/tool/lscomp.pl b/src/tool/lscomp.pl old mode 100755 new mode 100644 index e9d4a6448..fdf832a78 --- a/src/tool/lscomp.pl +++ b/src/tool/lscomp.pl @@ -1,573 +1,573 @@ -#!/usr/bin/perl -#use strict; -#use warnings; - -print " LSCOMP.PL\n"; -print " This PERL script creates files lscomp.tex and energylabel.latex\n"; -print " \n"; -print " File lscomp.tex contains energy level data with up to \n"; -print " three LS components with a contribution > 0.02 of the \n"; -print " total wave function. \n"; -print " \n"; -print " File energylabel.latex may be used by RTABTRANS2 to produce\n"; -print " LaTeX tables of transition data.\n"; -print " \n"; -print " Input files : state1.lsj.lbl and state2.lsj.lbl\n"; -print " state1.(c)h and state2.(c)h (optional for g_J factors)\n"; -print " Output files: lscomp.tex and energylabel.latex\n"; -print " Jorgen Ekman Sep. 2015\n"; -print " \n"; - -#$state1 = "even_5_b"; -#$state2 = "odd_5_b"; - -print " State 1? "; -chomp($state1 = <>); -print " State 2? "; -chomp($state2 = <>); -if (length($state2) == 0) { - $state2 = $state1; -} - - -$infile1 = $state1.".lsj.lbl"; -$infile2 = $state2.".lsj.lbl"; -$infile3 = $state1.".ch"; -$infile4 = $state2.".ch"; -$infile5 = $state1.".h"; -$infile6 = $state2.".h"; - -#Look for *.lsj.lbl files. If not found - exit program. -if (-e $infile1 && -e $infile2) { - printf(" Necessary input file(s) exist!\n"); - printf("\n"); -}else{ - printf(" Necessary input file(s) do not exist! Program terminates!\n"); - printf("\n"); - exit; -} - -printf(" Do you want to include Lande g_J factors in the energy table? (y/n) "); -chomp($gJinclude = <>); -if($gJinclude eq "y"){ - $gJinclude = 1; - print " Lande g_J factors from a CI calculation? (y/n) "; - chomp($ci = <>); - if($ci eq "y"){ - $ci = 1; - }else{ - $ci = 0; - } -}else{ - $gJinclude = 0; -} - -if($ci == 1 && $gJinclude ==1){ - if (-e $infile3 && -e $infile4) { - printf(" File(s) with g_J factors exist!\n"); - }else{ - printf(" File(s) with g_J factors do not exist!\n"); - $gJinclude = 0; - } -}elsif($ci == 0 && $gJinclude == 1){ - if (-e $infile5 && -e $infile6) { - printf(" File(s) with g_J factors exist!\n"); - }else{ - printf(" File(s) with g_J factors do not exist!\n"); - $gJinclude = 0; - } - -} - -printf("\n"); -printf(" Do you want an extra empty column for e_obs in the energy table? (y/n) "); -chomp($eobsinclude = <>); -if($eobsinclude eq "y"){ - $eobsinclude = 1; -}else{ - $eobsinclude = 0; -} -printf("\n"); -printf(" Inspect the labels of the states and \n"); -printf(" determine how many positions should be skipped in \n"); -printf(" the string that determines the label. For example\n"); -printf(" if all the states have a common core 1s(2) in the \n"); -printf(" label then 6 positions should be skipped\n"); - -printf("\n"); -printf(" How many positions should be skipped? "); -chomp($nochar = <>); - -$ec = 219474.6313702; #1 a.u = 219474.6313702 cm^-1 - -#READ CONTENT IN FILE 1 -#---------------------- -open(INPUTFILE1, $infile1); -$i=0; -while(){ - my($line) = $_; - chomp($line); - $linecontent[$i] = $line; - $size[$i] = scalar(split(' ', $linecontent[$i])); - $states1[$i] = $state1; - #printf("$linecontent[$i]\n"); - $i++; -} -$imax = $i; -close(INPUTFILE1); - -if($infile1 ne $infile2){ - - #READ CONTENT IN FILE 2 - #---------------------- - open(INPUTFILE2, $infile2); - $ii=0; - while(){ - my($line) = $_; - chomp($line); - $linecontent2[$ii] = $line; - $size2[$ii] = scalar(split(' ', $linecontent2[$ii])); - $states2[$ii] = $state2; - #printf("$linecontent2[$ii]\n"); - $ii++; - } - $iimax = $ii; - close(INPUTFILE2); - - #MERGE CONTENT OF THE FILES 1 & 2 - #-------------------------------- - for($i=0; $i<$iimax; $i++){ - $linecontent[$i+$imax] = $linecontent2[$i]; - $size[$i+$imax] = $size2[$i]; - $states1[$i+$imax] = $states2[$i]; - } - $imax = $imax + $iimax; -} - -if($gJinclude == 1) { - - #READ CONTENT IN FILE 3 - #---------------------- - if($ci == 1){ - open(INPUTFILE3, $infile3); - }else{ - open(INPUTFILE3, $infile5); - } - $i=0; - $j=0; - while(){ - if($i > 8){ - my($line) = $_; - chomp($line); - $linecontent3[$j] = $line; - #printf("$j $linecontent3[$j]\n"); - $j++; - } - $i++; - } - $iiimax = $j; - close(INPUTFILE3); - - if($infile3 ne $infile4) { - - #READ CONTENT IN FILE 4 - #---------------------- - if($ci == 1){ - open(INPUTFILE4, $infile4); - }else{ - open(INPUTFILE4, $infile6); - } - $i=0; - $j=0; - while(){ - if($i > 8){ - my($line) = $_; - chomp($line); - $linecontent4[$j] = $line; - #printf("$j $linecontent4[$j]\n"); - $j++; - } - $i++; - } - $iiiimax = $j; - close(INPUTFILE4); - - #MERGE CONTENT OF FILES 3 & 4 - #------------------------------ - for($i=0; $i<$iiiimax; $i++){ - $linecontent3[$i+$iiimax] = $linecontent4[$i]; - } - $iiimax = $iiimax + $iiiimax; - - } - - #EXTRACT RELEVANT DATA FROM CONTENT IN FILES 3 & 4 - #-------------------------------------------------- - #printf("\n"); - for($i=0; $i<$iiimax; $i++){ - @linesplit = split(' ', $linecontent3[$i]); - $or[$i] = $linesplit[0]; - $sp[$i] = $linesplit[1]; - $pa[$i] = $linesplit[2]; - $gj[$i] = $linesplit[5]; - my $substring = "D+00"; - my $substring2 = "D-01"; - my $substring3 = "D-02"; - if ($gj[$i] =~ /\Q$substring\E/) { - $gj[$i] = substr($gj[$i], 0, 7); - $gj[$i] = sprintf("%.5f", $gj[$i]); - } - if ($gj[$i] =~ /\Q$substring2\E/) { - $gj[$i] = substr($gj[$i], 0, 8); - $gj[$i] = $gj[$i]/10.0; - $gj[$i] = sprintf("%.5f", $gj[$i]); - } - if ($gj[$i] =~ /\Q$substring3\E/) { - $gj[$i] = substr($gj[$i], 0, 8); - $gj[$i] = $gj[$i]/100.0; - $gj[$i] = sprintf("%.5f", $gj[$i]); - } - } -} - -#CONTINUE PROCESSING DATA -#-------------------------------------------------- -printf("\n"); -$j=0; -for($i=0; $i<$imax; $i++){ - @linesplit = split(' ', $linecontent[$i]); - $size[$i] = scalar(@linesplit); - if($size[$i] == 5){ - $states[$j] = $states1[$i]; - $order[$j] = $linesplit[0]; - $spin[$j] = $linesplit[1]; - $parity[$j] = $linesplit[2]; - $energy[$j] = $linesplit[3]; - $energytot[$j] = $energy[$j]; - - if($gJinclude == 1) { - for($n=0; $n<$iiimax; $n++){ - if($order[$j] == $or[$n] && $spin[$j] eq $sp[$n] && $parity[$j] eq $pa[$n]){ - $gjval[$j] = $gj[$n]; - #printf("$order[$j] $or[$n] $spin[$j] $sp[$n] $parity[$j] $pa[$n] $gjval[$j]\n"); - } - } - } - - #printf("$energy[$j]\n"); - $k=$i+1; - $l=0; - while($size[$k] == 3){ - @linesplit = split(' ', $linecontent[$k]); - if($linesplit[1] < 0.02 && $l == 0){ - $wavemag[$j][$l] = $linesplit[1]; - $configuration[$j][$l] = $linesplit[2]; - - $conflength = length($configuration[$j][$l]); - $configuration2[$j][$l] = substr($configuration[$j][$l], 0, $conflength - 3); - - #printf("$order[$j] $spin[$j] $parity[$j] $energy[$j] $wavemag[$j][$l] $configuration[$j][$l]\n"); - $l++; - } - if($linesplit[1] >= 0.02 && $l < 3){ - $wavemag[$j][$l] = $linesplit[1]; - $configuration[$j][$l] = $linesplit[2]; - - $conflength = length($configuration[$j][$l]); - $configuration2[$j][$l] = substr($configuration[$j][$l], 0, $conflength - 3); - - #printf("$order[$j] $spin[$j] $parity[$j] $energy[$j] $wavemag[$j][$l] $configuration[$j][$l]\n"); - $l++; - } - $k++; - } - $lmax[$j] = $l; - $j++; - #printf("\n"); - } - $jmax = $j; -} - -#SORT DATA -#--------- -@energysort = sort { $a <=> $b } @energy; -#printf("@energysort\n"); -#printf("$energysort[0]\n"); -for($j=0; $j<$jmax; $j++){ - for($k=0; $k<$jmax; $k++){ - if($energy[$k] == $energysort[$j]){ - $energysortr7[$j] = sprintf "%.7f", $energysort[$j]; - - $eenergysort[$j] = $ec*($energysort[$j] - $energysort[0]); - $eenergysortr[$j] = sprintf "%.0f", $eenergysort[$j]; - $eenergysortr2[$j] = sprintf "%.2f", $eenergysort[$j]; - $eenergysortrsep[$j] = thousandsep($eenergysortr[$j]); - $statessort[$j] = $states[$k]; - $ordersort[$j] = $order[$k]; - $spinsort[$j] = $spin[$k]; - - if($gJinclude == 1) { - $gjvalsort[$j] = $gjval[$k]; - } - - $spinsort2[$j] = $spinsort[$j]; - - $paritysort[$j] = $parity[$k]; - $lmaxsort[$j] = $lmax[$k]; - for($l=0; $l<$lmax[$k]; $l++){ - $wavemagsort[$j][$l] = $wavemag[$k][$l]; - $wavemagsortr[$j][$l] = sprintf "%.2f", $wavemagsort[$j][$l]; - $configurationsort[$j][$l] = $configuration[$k][$l]; - $configurationsort2[$j][$l] = $configuration2[$k][$l]; - #printf("$ordersort[$j] $spinsort[$j] $paritysort[$j] $eenergysortr[$j] $eenergysort[$j] $wavemagsortr[$j][$l] $wavemagsort[$j][$l] $configurationsort[$j][$l]\n"); - } - #printf("$k $j $energy[$k] $energysorted[$j]\n"); - } - } -} - - -#JE testing -$nom = 0; -$testconfje = level2($configurationsort[$nom][1], $spinsort[$nom], $paritysort[$nom], 1, $nochar); -#printf("-----------------------\n"); -#printf("$configurationsort[$nom][1]\n"); -#printf("$testconfje\n"); -#printf("-----------------------\n"); - -#PRODUCE LATEX STYLE CONFIGURATIONS -#---------------------------------- -for($i=0; $i<$jmax; $i++){ - for($l=0; $l<$lmaxsort[$i]; $l++){ #energy sorted - if($l==0){ - $testconfsort[$i][$l] = level2($configurationsort[$i][$l], $spinsort[$i], $paritysort[$i], 0, $nochar); - $teststring[$i] = $wavemagsortr[$i][$l]; - $llss[$i] = lsj($configurationsort[$i][$l]); - $llss[$i] = "\$".$llss[$i]."_".$spinsort2[$i]; - if($paritysort[$i] eq "-"){ #add negative parity symbol "o" to LSJ term - $llss[$i] .= "^{\\circ}\$"; - }else{ - $llss[$i] .= "\$"; - } - }else{ - $testconfsort[$i][$l] = level2($configurationsort[$i][$l], $spinsort[$i], $paritysort[$i], 1, $nochar); - $llss2 = lsj($configurationsort[$i][$l]); - $teststring[$i] = $teststring[$i]." + ".$wavemagsortr[$i][$l]."~".$testconfsort[$i][$l]; - } - } -} - -for($i=0; $i<$jmax; $i++){ - $test = 0; - for($j=$i+1; $j<$jmax; $j++){ - if(($i != $j) && ($configurationsort[$i][0] eq $configurationsort[$j][0]) && ($spinsort[$i] eq $spinsort[$j])){ - if($test == 0) { - $testconfsort[$i][0] = $testconfsort[$i][0]."\$_a\$"; - $testconfsort[$j][0] = $testconfsort[$j][0]."\$_b\$"; - } - if($test == 1) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_c\$";} - if($test == 2) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_d\$";} - if($test == 3) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_e\$";} - if($test == 4) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_f\$";} - if($test == 5) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_g\$";} - $test++; - } - } -} - -#PRODUCE ENERGYLABEL FILE CALLED energylabel -#------------------------------------------- -open (MYOUTPUTFILE, '>energylabel.latex'); -for($j=0; $j<9; $j++){ - printf MYOUTPUTFILE "\n"; -} -for($j=0; $j<3; $j++){ - printf MYOUTPUTFILE "--------------\n"; -} -for($j=0; $j<$jmax; $j++){ - printf MYOUTPUTFILE "%3s %2s %3s %2s %15s %11s %-10s %-50s\n" , $j+1, $ordersort[$j], $spinsort[$j], $paritysort[$j], $energysortr7[$j], $eenergysortr2[$j], $statessort[$j],$testconfsort[$j][0]; -} -close(MYOUTPUTFILE); - - - -#PRODUCE LATEX TABLE WITH LEVEL INFORMATION -#------------------------------------------ -$header_gJ_eobs = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$E(OBS) \$ & \$g_J \$ \\\\ \n"; -$header_gJ = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$g_J \$ \\\\ \n"; -$header_eobs = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$E(OBS) \$ \\\\ \n"; -$header = "No. & State & \$LS\$-composition & \$E(CI) \$ \\\\ \n"; - -open (MYOUTPUTFILE2, '>lscomp.tex'); -print MYOUTPUTFILE2 "\\documentclass[12pt]{article}\n"; -print MYOUTPUTFILE2 "\\usepackage{longtable}\n"; -print MYOUTPUTFILE2 "\\usepackage[cm]{fullpage}\n"; -print MYOUTPUTFILE2 "\\thispagestyle{empty}\n"; -print MYOUTPUTFILE2 "\\begin{document}\n"; -print MYOUTPUTFILE2 "\{\\scriptsize\n"; -if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrrr}\n";} -if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrr}\n";} -if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrr}\n";} -if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllr}\n";} -print MYOUTPUTFILE2 "\\caption\{Energies.....\}\\\\ \n"; -print MYOUTPUTFILE2 "\\hline\n"; -if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_gJ_eobs\n";} -if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header_gJ\n";} -if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_eobs\n";} -if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header\n";} -print MYOUTPUTFILE2 "\\hline\n"; -print MYOUTPUTFILE2 "\\endfirsthead\n"; -print MYOUTPUTFILE2 "\\caption\{Continued.\}\\\\ \n"; -print MYOUTPUTFILE2 "\\hline\n"; -if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_gJ_eobs\n";} -if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header_gJ\n";} -if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_eobs\n";} -if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header\n";} -print MYOUTPUTFILE2 "\\hline\n"; -print MYOUTPUTFILE2 "\\endhead\n"; -print MYOUTPUTFILE2 "\\hline\n"; -print MYOUTPUTFILE2 "\\endfoot\n"; - -for ($i=0; $i<$jmax; $i++) -{ - if ($gJinclude == 1 && $eobsinclude == 1) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-2s & %-7s\\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], " ", $gjvalsort[$i];} - if ($gJinclude == 1 && $eobsinclude == 0) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-7s\\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], $gjvalsort[$i];} - if ($gJinclude == 0 && $eobsinclude == 1) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-2s \\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], " ";} - if ($gJinclude == 0 && $eobsinclude == 0) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s \\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i]} -} - -print MYOUTPUTFILE2 "\\hline \n"; -print MYOUTPUTFILE2 "\\end{longtable}\n"; -print MYOUTPUTFILE2 "\}\n"; - -print MYOUTPUTFILE2 "\\end{document}\n"; -close(MYOUTPUTFILE2); - -print " Files lscomp.tex and energylabel.latex written to disc. \n"; -print "\n"; - -#FUNCTION LSJ -#-------------- -sub lsj { - ($confstring) = @_; - $conflength = length($confstring); - - $term = substr($confstring, $conflength - 2, 2); - $sterm = substr($term, 0, 1); #extract 2S+1 - $lterm = substr($term, 1, 1); #extract L - $lsj2 = "^{".$sterm."}".$lterm; #form LS term - - #$lsj2 = "\$".$lsj2."\$"; - - return($lsj2); -} - -#FUNCTION LEVEL 2 (NEW) -#---------------------- -sub level2 { - ($confstring, $jvalue, $parity2, $levelflag, $rmnochar) = @_; - $conflength = length($confstring); - $conf = substr($confstring, 0, $conflength - 3); # remove LS term at the end (ex. _3D) - $conf = substr($conf, $rmnochar, $conflength - 3); - @confsplit = split('\.', $conf); # split configuration by dots "." - $size = scalar(@confsplit); # number of dot separeted strings - #printf("$conf\n"); - for ($j=$confflag; $j<$size; $j++){ # loop over dot seprated strings - #printf("\n"); - #printf("$confsplit[$j]\n"); - #printf("--------------------\n"); - #if($confsplit[$j] =~ /\Q(\E/ && $confsplit[$j] !~ /\Q_\E/){ # if more than nl electron - if($confsplit[$j] =~ /\Q(\E/){ # if more than nl electron - #printf("check\n"); - $confpartlength = length($confsplit[$j]); - if($confpartlength < 8){ - $nl = substr($confsplit[$j], 0, 2); # extract nl - $checkpow = substr($confsplit[$j], 4, 1); - if($checkpow eq ")"){ # check if char 4 is ")" example 5s(2) - $pow = substr($confsplit[$j], 3, 1); # if so extract power = 1 char - }else{ - $pow = substr($confsplit[$j], 3, 2); # if not extract power = 2 chars - } - $nlpow = $nl."^{".$pow."}"; # contruct nl^pow latex style - #printf("$nlpow\n"); - }else{ - $nl = substr($confsplit[$j], 0, 2); - $checkpow = substr($confsplit[$j], 4, 1); - if($checkpow eq ")"){ # check if char 4 is ")" example 5s(2) - $pow = substr($confsplit[$j], 3, 1); # if so extract power = 1 char - }else{ - $pow = substr($confsplit[$j], 3, 2); # if not extract power = 2 chars - } - if($confsplit[$j] =~ /\Q_\E/){ - #printf("end\n"); - $intterm3 = substr($confsplit[$j], $confpartlength - 2, 1); - $intterm4 = substr($confsplit[$j], $confpartlength - 1, 1); - $intterm5 = substr($confsplit[$j], $confpartlength - 6, 1); - $intterm6 = substr($confsplit[$j], $confpartlength - 5, 1); - $intterm7 = substr($confsplit[$j], $confpartlength - 4, 1); - $nlpow = $nl."^{".$pow."}"."(^{$intterm5}_{$intterm7}$intterm6)"."~^{$intterm3}$intterm4"; # contruct nl^pow latex style - }else{ - #printf("not end\n"); - $intterm5 = substr($confsplit[$j], $confpartlength - 3, 1); - $intterm6 = substr($confsplit[$j], $confpartlength - 2, 1); - $intterm7 = substr($confsplit[$j], $confpartlength - 1, 1); - $nlpow = $nl."^{".$pow."}"."(^{$intterm5}_{$intterm7}$intterm6)"; # contruct nl^pow latex style - #$nlpow = $nl."(^{".$intterm3."}".$intterm4.")"; - #printf("$nlpow\n"); - } - } - }else{ - #printf("check 2\n"); #if exactly 1 nl electron - if($confsplit[$j] =~ /\Q_\E/){ - $nl = substr($confsplit[$j], 0, 2); - $intterm1 = substr($confsplit[$j], 3, 1); - $intterm2 = substr($confsplit[$j], 4, 1); - $nlpow = $nl."~^{".$intterm1."}".$intterm2; - }else{ - $nlpow = substr($confsplit[$j], 0, 2); - } - } - if($j == $confflag){ - $conf2 = $nlpow; - }else{ - $conf2 = $conf2."\\,".$nlpow; - } - } - $term = substr($confstring, $conflength - 2, 2); - $sterm = substr($term, 0, 1); #extract 2S+1 - $lterm = substr($term, 1, 1); #extract L - $lsj = "^{".$sterm."}".$lterm."\_{".$jvalue."}"; #form LSJ term - $lsj2 = "^{".$sterm."}".$lterm; #form LS term - if($parity2 eq "-"){ #add negative parity symbol "o" to LSJ term - $lsj .= "^{\\circ}"; - $lsj2 .= "^{\\circ}"; - } - if($levelflag == 0){ - $conf2 = $conf2."~".$lsj; - }else{ - $conf2 = $conf2."~".$lsj2; - } - $conf2 = "\$".$conf2."\$"; - - return($conf2); -} - -#FUNCTION THOUSANDSEP -#-------------------- -sub thousandsep { - ($unsepenergy) = @_; - $lenergy = length($unsepenergy); - if($lenergy < 4){ - $sepenergy = $unsepenergy; - }elsif($lenergy > 3 && $lenergy < 7){ - $lastpart = substr($unsepenergy, $lenergy - 3, 3); - $firstpart = substr($unsepenergy, 0, $lenergy - 3); - $sepenergy = $firstpart."~".$lastpart; - }elsif($lenergy > 6){ - $lastpart = substr($unsepenergy, $lenergy - 3, 3); - $middlepart = substr($unsepenergy, $lenergy - 6, 3); - $firstpart = substr($unsepenergy, 0, $lenergy - 6); - $sepenergy = $firstpart."~".$middlepart."~".$lastpart; - } - return($sepenergy); -} +#!/usr/bin/perl +#use strict; +#use warnings; + +print " LSCOMP.PL\n"; +print " This PERL script creates files lscomp.tex and energylabel.latex\n"; +print " \n"; +print " File lscomp.tex contains energy level data with up to \n"; +print " three LS components with a contribution > 0.02 of the \n"; +print " total wave function. \n"; +print " \n"; +print " File energylabel.latex may be used by RTABTRANS2 to produce\n"; +print " LaTeX tables of transition data.\n"; +print " \n"; +print " Input files : state1.lsj.lbl and state2.lsj.lbl\n"; +print " state1.(c)h and state2.(c)h (optional for g_J factors)\n"; +print " Output files: lscomp.tex and energylabel.latex\n"; +print " Jorgen Ekman Sep. 2015\n"; +print " \n"; + +#$state1 = "even_5_b"; +#$state2 = "odd_5_b"; + +print " State 1? "; +chomp($state1 = <>); +print " State 2? "; +chomp($state2 = <>); +if (length($state2) == 0) { + $state2 = $state1; +} + + +$infile1 = $state1.".lsj.lbl"; +$infile2 = $state2.".lsj.lbl"; +$infile3 = $state1.".ch"; +$infile4 = $state2.".ch"; +$infile5 = $state1.".h"; +$infile6 = $state2.".h"; + +#Look for *.lsj.lbl files. If not found - exit program. +if (-e $infile1 && -e $infile2) { + printf(" Necessary input file(s) exist!\n"); + printf("\n"); +}else{ + printf(" Necessary input file(s) do not exist! Program terminates!\n"); + printf("\n"); + exit; +} + +printf(" Do you want to include Lande g_J factors in the energy table? (y/n) "); +chomp($gJinclude = <>); +if($gJinclude eq "y"){ + $gJinclude = 1; + print " Lande g_J factors from a CI calculation? (y/n) "; + chomp($ci = <>); + if($ci eq "y"){ + $ci = 1; + }else{ + $ci = 0; + } +}else{ + $gJinclude = 0; +} + +if($ci == 1 && $gJinclude ==1){ + if (-e $infile3 && -e $infile4) { + printf(" File(s) with g_J factors exist!\n"); + }else{ + printf(" File(s) with g_J factors do not exist!\n"); + $gJinclude = 0; + } +}elsif($ci == 0 && $gJinclude == 1){ + if (-e $infile5 && -e $infile6) { + printf(" File(s) with g_J factors exist!\n"); + }else{ + printf(" File(s) with g_J factors do not exist!\n"); + $gJinclude = 0; + } + +} + +printf("\n"); +printf(" Do you want an extra empty column for e_obs in the energy table? (y/n) "); +chomp($eobsinclude = <>); +if($eobsinclude eq "y"){ + $eobsinclude = 1; +}else{ + $eobsinclude = 0; +} +printf("\n"); +printf(" Inspect the labels of the states and \n"); +printf(" determine how many positions should be skipped in \n"); +printf(" the string that determines the label. For example\n"); +printf(" if all the states have a common core 1s(2) in the \n"); +printf(" label then 6 positions should be skipped\n"); + +printf("\n"); +printf(" How many positions should be skipped? "); +chomp($nochar = <>); + +$ec = 219474.6313702; #1 a.u = 219474.6313702 cm^-1 + +#READ CONTENT IN FILE 1 +#---------------------- +open(INPUTFILE1, $infile1); +$i=0; +while(){ + my($line) = $_; + chomp($line); + $linecontent[$i] = $line; + $size[$i] = scalar(split(' ', $linecontent[$i])); + $states1[$i] = $state1; + #printf("$linecontent[$i]\n"); + $i++; +} +$imax = $i; +close(INPUTFILE1); + +if($infile1 ne $infile2){ + + #READ CONTENT IN FILE 2 + #---------------------- + open(INPUTFILE2, $infile2); + $ii=0; + while(){ + my($line) = $_; + chomp($line); + $linecontent2[$ii] = $line; + $size2[$ii] = scalar(split(' ', $linecontent2[$ii])); + $states2[$ii] = $state2; + #printf("$linecontent2[$ii]\n"); + $ii++; + } + $iimax = $ii; + close(INPUTFILE2); + + #MERGE CONTENT OF THE FILES 1 & 2 + #-------------------------------- + for($i=0; $i<$iimax; $i++){ + $linecontent[$i+$imax] = $linecontent2[$i]; + $size[$i+$imax] = $size2[$i]; + $states1[$i+$imax] = $states2[$i]; + } + $imax = $imax + $iimax; +} + +if($gJinclude == 1) { + + #READ CONTENT IN FILE 3 + #---------------------- + if($ci == 1){ + open(INPUTFILE3, $infile3); + }else{ + open(INPUTFILE3, $infile5); + } + $i=0; + $j=0; + while(){ + if($i > 8){ + my($line) = $_; + chomp($line); + $linecontent3[$j] = $line; + #printf("$j $linecontent3[$j]\n"); + $j++; + } + $i++; + } + $iiimax = $j; + close(INPUTFILE3); + + if($infile3 ne $infile4) { + + #READ CONTENT IN FILE 4 + #---------------------- + if($ci == 1){ + open(INPUTFILE4, $infile4); + }else{ + open(INPUTFILE4, $infile6); + } + $i=0; + $j=0; + while(){ + if($i > 8){ + my($line) = $_; + chomp($line); + $linecontent4[$j] = $line; + #printf("$j $linecontent4[$j]\n"); + $j++; + } + $i++; + } + $iiiimax = $j; + close(INPUTFILE4); + + #MERGE CONTENT OF FILES 3 & 4 + #------------------------------ + for($i=0; $i<$iiiimax; $i++){ + $linecontent3[$i+$iiimax] = $linecontent4[$i]; + } + $iiimax = $iiimax + $iiiimax; + + } + + #EXTRACT RELEVANT DATA FROM CONTENT IN FILES 3 & 4 + #-------------------------------------------------- + #printf("\n"); + for($i=0; $i<$iiimax; $i++){ + @linesplit = split(' ', $linecontent3[$i]); + $or[$i] = $linesplit[0]; + $sp[$i] = $linesplit[1]; + $pa[$i] = $linesplit[2]; + $gj[$i] = $linesplit[5]; + my $substring = "D+00"; + my $substring2 = "D-01"; + my $substring3 = "D-02"; + if ($gj[$i] =~ /\Q$substring\E/) { + $gj[$i] = substr($gj[$i], 0, 7); + $gj[$i] = sprintf("%.5f", $gj[$i]); + } + if ($gj[$i] =~ /\Q$substring2\E/) { + $gj[$i] = substr($gj[$i], 0, 8); + $gj[$i] = $gj[$i]/10.0; + $gj[$i] = sprintf("%.5f", $gj[$i]); + } + if ($gj[$i] =~ /\Q$substring3\E/) { + $gj[$i] = substr($gj[$i], 0, 8); + $gj[$i] = $gj[$i]/100.0; + $gj[$i] = sprintf("%.5f", $gj[$i]); + } + } +} + +#CONTINUE PROCESSING DATA +#-------------------------------------------------- +printf("\n"); +$j=0; +for($i=0; $i<$imax; $i++){ + @linesplit = split(' ', $linecontent[$i]); + $size[$i] = scalar(@linesplit); + if($size[$i] == 5){ + $states[$j] = $states1[$i]; + $order[$j] = $linesplit[0]; + $spin[$j] = $linesplit[1]; + $parity[$j] = $linesplit[2]; + $energy[$j] = $linesplit[3]; + $energytot[$j] = $energy[$j]; + + if($gJinclude == 1) { + for($n=0; $n<$iiimax; $n++){ + if($order[$j] == $or[$n] && $spin[$j] eq $sp[$n] && $parity[$j] eq $pa[$n]){ + $gjval[$j] = $gj[$n]; + #printf("$order[$j] $or[$n] $spin[$j] $sp[$n] $parity[$j] $pa[$n] $gjval[$j]\n"); + } + } + } + + #printf("$energy[$j]\n"); + $k=$i+1; + $l=0; + while($size[$k] == 3){ + @linesplit = split(' ', $linecontent[$k]); + if($linesplit[1] < 0.02 && $l == 0){ + $wavemag[$j][$l] = $linesplit[1]; + $configuration[$j][$l] = $linesplit[2]; + + $conflength = length($configuration[$j][$l]); + $configuration2[$j][$l] = substr($configuration[$j][$l], 0, $conflength - 3); + + #printf("$order[$j] $spin[$j] $parity[$j] $energy[$j] $wavemag[$j][$l] $configuration[$j][$l]\n"); + $l++; + } + if($linesplit[1] >= 0.02 && $l < 3){ + $wavemag[$j][$l] = $linesplit[1]; + $configuration[$j][$l] = $linesplit[2]; + + $conflength = length($configuration[$j][$l]); + $configuration2[$j][$l] = substr($configuration[$j][$l], 0, $conflength - 3); + + #printf("$order[$j] $spin[$j] $parity[$j] $energy[$j] $wavemag[$j][$l] $configuration[$j][$l]\n"); + $l++; + } + $k++; + } + $lmax[$j] = $l; + $j++; + #printf("\n"); + } + $jmax = $j; +} + +#SORT DATA +#--------- +@energysort = sort { $a <=> $b } @energy; +#printf("@energysort\n"); +#printf("$energysort[0]\n"); +for($j=0; $j<$jmax; $j++){ + for($k=0; $k<$jmax; $k++){ + if($energy[$k] == $energysort[$j]){ + $energysortr7[$j] = sprintf "%.7f", $energysort[$j]; + + $eenergysort[$j] = $ec*($energysort[$j] - $energysort[0]); + $eenergysortr[$j] = sprintf "%.0f", $eenergysort[$j]; + $eenergysortr2[$j] = sprintf "%.2f", $eenergysort[$j]; + $eenergysortrsep[$j] = thousandsep($eenergysortr[$j]); + $statessort[$j] = $states[$k]; + $ordersort[$j] = $order[$k]; + $spinsort[$j] = $spin[$k]; + + if($gJinclude == 1) { + $gjvalsort[$j] = $gjval[$k]; + } + + $spinsort2[$j] = $spinsort[$j]; + + $paritysort[$j] = $parity[$k]; + $lmaxsort[$j] = $lmax[$k]; + for($l=0; $l<$lmax[$k]; $l++){ + $wavemagsort[$j][$l] = $wavemag[$k][$l]; + $wavemagsortr[$j][$l] = sprintf "%.2f", $wavemagsort[$j][$l]; + $configurationsort[$j][$l] = $configuration[$k][$l]; + $configurationsort2[$j][$l] = $configuration2[$k][$l]; + #printf("$ordersort[$j] $spinsort[$j] $paritysort[$j] $eenergysortr[$j] $eenergysort[$j] $wavemagsortr[$j][$l] $wavemagsort[$j][$l] $configurationsort[$j][$l]\n"); + } + #printf("$k $j $energy[$k] $energysorted[$j]\n"); + } + } +} + + +#JE testing +$nom = 0; +$testconfje = level2($configurationsort[$nom][1], $spinsort[$nom], $paritysort[$nom], 1, $nochar); +#printf("-----------------------\n"); +#printf("$configurationsort[$nom][1]\n"); +#printf("$testconfje\n"); +#printf("-----------------------\n"); + +#PRODUCE LATEX STYLE CONFIGURATIONS +#---------------------------------- +for($i=0; $i<$jmax; $i++){ + for($l=0; $l<$lmaxsort[$i]; $l++){ #energy sorted + if($l==0){ + $testconfsort[$i][$l] = level2($configurationsort[$i][$l], $spinsort[$i], $paritysort[$i], 0, $nochar); + $teststring[$i] = $wavemagsortr[$i][$l]; + $llss[$i] = lsj($configurationsort[$i][$l]); + $llss[$i] = "\$".$llss[$i]."_".$spinsort2[$i]; + if($paritysort[$i] eq "-"){ #add negative parity symbol "o" to LSJ term + $llss[$i] .= "^{\\circ}\$"; + }else{ + $llss[$i] .= "\$"; + } + }else{ + $testconfsort[$i][$l] = level2($configurationsort[$i][$l], $spinsort[$i], $paritysort[$i], 1, $nochar); + $llss2 = lsj($configurationsort[$i][$l]); + $teststring[$i] = $teststring[$i]." + ".$wavemagsortr[$i][$l]."~".$testconfsort[$i][$l]; + } + } +} + +for($i=0; $i<$jmax; $i++){ + $test = 0; + for($j=$i+1; $j<$jmax; $j++){ + if(($i != $j) && ($configurationsort[$i][0] eq $configurationsort[$j][0]) && ($spinsort[$i] eq $spinsort[$j])){ + if($test == 0) { + $testconfsort[$i][0] = $testconfsort[$i][0]."\$_a\$"; + $testconfsort[$j][0] = $testconfsort[$j][0]."\$_b\$"; + } + if($test == 1) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_c\$";} + if($test == 2) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_d\$";} + if($test == 3) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_e\$";} + if($test == 4) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_f\$";} + if($test == 5) {$testconfsort[$j][0] = $testconfsort[$j][0]."\$_g\$";} + $test++; + } + } +} + +#PRODUCE ENERGYLABEL FILE CALLED energylabel +#------------------------------------------- +open (MYOUTPUTFILE, '>energylabel.latex'); +for($j=0; $j<9; $j++){ + printf MYOUTPUTFILE "\n"; +} +for($j=0; $j<3; $j++){ + printf MYOUTPUTFILE "--------------\n"; +} +for($j=0; $j<$jmax; $j++){ + printf MYOUTPUTFILE "%3s %2s %3s %2s %15s %11s %-10s %-50s\n" , $j+1, $ordersort[$j], $spinsort[$j], $paritysort[$j], $energysortr7[$j], $eenergysortr2[$j], $statessort[$j],$testconfsort[$j][0]; +} +close(MYOUTPUTFILE); + + + +#PRODUCE LATEX TABLE WITH LEVEL INFORMATION +#------------------------------------------ +$header_gJ_eobs = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$E(OBS) \$ & \$g_J \$ \\\\ \n"; +$header_gJ = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$g_J \$ \\\\ \n"; +$header_eobs = "No. & State & \$LS\$-composition & \$E(CI) \$ & \$E(OBS) \$ \\\\ \n"; +$header = "No. & State & \$LS\$-composition & \$E(CI) \$ \\\\ \n"; + +open (MYOUTPUTFILE2, '>lscomp.tex'); +print MYOUTPUTFILE2 "\\documentclass[12pt]{article}\n"; +print MYOUTPUTFILE2 "\\usepackage{longtable}\n"; +print MYOUTPUTFILE2 "\\usepackage[cm]{fullpage}\n"; +print MYOUTPUTFILE2 "\\thispagestyle{empty}\n"; +print MYOUTPUTFILE2 "\\begin{document}\n"; +print MYOUTPUTFILE2 "\{\\scriptsize\n"; +if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrrr}\n";} +if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrr}\n";} +if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllrr}\n";} +if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "\\begin{longtable}{\@\{\}rllr}\n";} +print MYOUTPUTFILE2 "\\caption\{Energies.....\}\\\\ \n"; +print MYOUTPUTFILE2 "\\hline\n"; +if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_gJ_eobs\n";} +if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header_gJ\n";} +if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_eobs\n";} +if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header\n";} +print MYOUTPUTFILE2 "\\hline\n"; +print MYOUTPUTFILE2 "\\endfirsthead\n"; +print MYOUTPUTFILE2 "\\caption\{Continued.\}\\\\ \n"; +print MYOUTPUTFILE2 "\\hline\n"; +if ($gJinclude == 1 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_gJ_eobs\n";} +if ($gJinclude == 1 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header_gJ\n";} +if ($gJinclude == 0 && $eobsinclude == 1) {print MYOUTPUTFILE2 "$header_eobs\n";} +if ($gJinclude == 0 && $eobsinclude == 0) {print MYOUTPUTFILE2 "$header\n";} +print MYOUTPUTFILE2 "\\hline\n"; +print MYOUTPUTFILE2 "\\endhead\n"; +print MYOUTPUTFILE2 "\\hline\n"; +print MYOUTPUTFILE2 "\\endfoot\n"; + +for ($i=0; $i<$jmax; $i++) +{ + if ($gJinclude == 1 && $eobsinclude == 1) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-2s & %-7s\\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], " ", $gjvalsort[$i];} + if ($gJinclude == 1 && $eobsinclude == 0) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-7s\\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], $gjvalsort[$i];} + if ($gJinclude == 0 && $eobsinclude == 1) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s & %-2s \\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i], " ";} + if ($gJinclude == 0 && $eobsinclude == 0) {printf MYOUTPUTFILE2 "%-3s & %-50s & %-90s & %-12s \\\\ \n", $i+1, $testconfsort[$i][0], $teststring[$i], $eenergysortrsep[$i]} +} + +print MYOUTPUTFILE2 "\\hline \n"; +print MYOUTPUTFILE2 "\\end{longtable}\n"; +print MYOUTPUTFILE2 "\}\n"; + +print MYOUTPUTFILE2 "\\end{document}\n"; +close(MYOUTPUTFILE2); + +print " Files lscomp.tex and energylabel.latex written to disc. \n"; +print "\n"; + +#FUNCTION LSJ +#-------------- +sub lsj { + ($confstring) = @_; + $conflength = length($confstring); + + $term = substr($confstring, $conflength - 2, 2); + $sterm = substr($term, 0, 1); #extract 2S+1 + $lterm = substr($term, 1, 1); #extract L + $lsj2 = "^{".$sterm."}".$lterm; #form LS term + + #$lsj2 = "\$".$lsj2."\$"; + + return($lsj2); +} + +#FUNCTION LEVEL 2 (NEW) +#---------------------- +sub level2 { + ($confstring, $jvalue, $parity2, $levelflag, $rmnochar) = @_; + $conflength = length($confstring); + $conf = substr($confstring, 0, $conflength - 3); # remove LS term at the end (ex. _3D) + $conf = substr($conf, $rmnochar, $conflength - 3); + @confsplit = split('\.', $conf); # split configuration by dots "." + $size = scalar(@confsplit); # number of dot separeted strings + #printf("$conf\n"); + for ($j=$confflag; $j<$size; $j++){ # loop over dot seprated strings + #printf("\n"); + #printf("$confsplit[$j]\n"); + #printf("--------------------\n"); + #if($confsplit[$j] =~ /\Q(\E/ && $confsplit[$j] !~ /\Q_\E/){ # if more than nl electron + if($confsplit[$j] =~ /\Q(\E/){ # if more than nl electron + #printf("check\n"); + $confpartlength = length($confsplit[$j]); + if($confpartlength < 8){ + $nl = substr($confsplit[$j], 0, 2); # extract nl + $checkpow = substr($confsplit[$j], 4, 1); + if($checkpow eq ")"){ # check if char 4 is ")" example 5s(2) + $pow = substr($confsplit[$j], 3, 1); # if so extract power = 1 char + }else{ + $pow = substr($confsplit[$j], 3, 2); # if not extract power = 2 chars + } + $nlpow = $nl."^{".$pow."}"; # contruct nl^pow latex style + #printf("$nlpow\n"); + }else{ + $nl = substr($confsplit[$j], 0, 2); + $checkpow = substr($confsplit[$j], 4, 1); + if($checkpow eq ")"){ # check if char 4 is ")" example 5s(2) + $pow = substr($confsplit[$j], 3, 1); # if so extract power = 1 char + }else{ + $pow = substr($confsplit[$j], 3, 2); # if not extract power = 2 chars + } + if($confsplit[$j] =~ /\Q_\E/){ + #printf("end\n"); + $intterm3 = substr($confsplit[$j], $confpartlength - 2, 1); + $intterm4 = substr($confsplit[$j], $confpartlength - 1, 1); + $intterm5 = substr($confsplit[$j], $confpartlength - 6, 1); + $intterm6 = substr($confsplit[$j], $confpartlength - 5, 1); + $intterm7 = substr($confsplit[$j], $confpartlength - 4, 1); + $nlpow = $nl."^{".$pow."}"."(^{$intterm5}_{$intterm7}$intterm6)"."~^{$intterm3}$intterm4"; # contruct nl^pow latex style + }else{ + #printf("not end\n"); + $intterm5 = substr($confsplit[$j], $confpartlength - 3, 1); + $intterm6 = substr($confsplit[$j], $confpartlength - 2, 1); + $intterm7 = substr($confsplit[$j], $confpartlength - 1, 1); + $nlpow = $nl."^{".$pow."}"."(^{$intterm5}_{$intterm7}$intterm6)"; # contruct nl^pow latex style + #$nlpow = $nl."(^{".$intterm3."}".$intterm4.")"; + #printf("$nlpow\n"); + } + } + }else{ + #printf("check 2\n"); #if exactly 1 nl electron + if($confsplit[$j] =~ /\Q_\E/){ + $nl = substr($confsplit[$j], 0, 2); + $intterm1 = substr($confsplit[$j], 3, 1); + $intterm2 = substr($confsplit[$j], 4, 1); + $nlpow = $nl."~^{".$intterm1."}".$intterm2; + }else{ + $nlpow = substr($confsplit[$j], 0, 2); + } + } + if($j == $confflag){ + $conf2 = $nlpow; + }else{ + $conf2 = $conf2."\\,".$nlpow; + } + } + $term = substr($confstring, $conflength - 2, 2); + $sterm = substr($term, 0, 1); #extract 2S+1 + $lterm = substr($term, 1, 1); #extract L + $lsj = "^{".$sterm."}".$lterm."\_{".$jvalue."}"; #form LSJ term + $lsj2 = "^{".$sterm."}".$lterm; #form LS term + if($parity2 eq "-"){ #add negative parity symbol "o" to LSJ term + $lsj .= "^{\\circ}"; + $lsj2 .= "^{\\circ}"; + } + if($levelflag == 0){ + $conf2 = $conf2."~".$lsj; + }else{ + $conf2 = $conf2."~".$lsj2; + } + $conf2 = "\$".$conf2."\$"; + + return($conf2); +} + +#FUNCTION THOUSANDSEP +#-------------------- +sub thousandsep { + ($unsepenergy) = @_; + $lenergy = length($unsepenergy); + if($lenergy < 4){ + $sepenergy = $unsepenergy; + }elsif($lenergy > 3 && $lenergy < 7){ + $lastpart = substr($unsepenergy, $lenergy - 3, 3); + $firstpart = substr($unsepenergy, 0, $lenergy - 3); + $sepenergy = $firstpart."~".$lastpart; + }elsif($lenergy > 6){ + $lastpart = substr($unsepenergy, $lenergy - 3, 3); + $middlepart = substr($unsepenergy, $lenergy - 6, 3); + $firstpart = substr($unsepenergy, 0, $lenergy - 6); + $sepenergy = $firstpart."~".$middlepart."~".$lastpart; + } + return($sepenergy); +} diff --git a/src/tool/rasfsplit.f90 b/src/tool/rasfsplit.f90 index 4ef67a063..afda1ea57 100644 --- a/src/tool/rasfsplit.f90 +++ b/src/tool/rasfsplit.f90 @@ -91,7 +91,7 @@ program rasfsplit nblock = 0 nblockodd = 0 nblockeven = 0 -do +do string1 = string2 read(36,'(a)',end=99) string2 if (string2(2:2).eq.'*') then @@ -153,7 +153,7 @@ program rasfsplit end do i = 1 -do +do read(36,'(a)',end=999) string1 if (string1(2:2).eq.'*') then i = i + 1 @@ -169,7 +169,7 @@ program rasfsplit ! Now open the name.(c)m files do l = 1,2 - if (l.eq.1) then + if (l.eq.1) then open(unit=36,file=trim(name)//'.m',status='old',form='unformatted',iostat=ios) else open(unit=36,file=trim(name)//'.cm',status='old',form='unformatted',iostat=ios) @@ -180,7 +180,7 @@ program rasfsplit else write(*,*) 'File ',trim(name)//'.cm ','available' end if - write(*,*) + write(*,*) read(36,iostat=ios) G92MIX read(36) nelec, ncftot, nw, nvectot, nvecsize, nblock write(*,*) ' nelec = ', nelec @@ -207,7 +207,7 @@ program rasfsplit else open(unit=36+i,file=trim(name)//trim(blockstring(i))//'.cm',status='unknown',form='unformatted') end if -! Write the first two lines +! Write the first two lines write(36+i) G92MIX write(36+i) nelec, ncfblk(i), nw, nevblk(i), ncfblk(i)*nevblk(i), 1 ! Write the data for the block @@ -226,7 +226,7 @@ program rasfsplit do i = 1,nblock close(36+i) end do - + deallocate(ncfblk) deallocate(evec) diff --git a/src/tool/rcsfblock.f90 b/src/tool/rcsfblock.f90 index 6bd492dce..30fdc3dbb 100644 --- a/src/tool/rcsfblock.f90 +++ b/src/tool/rcsfblock.f90 @@ -226,7 +226,7 @@ PROGRAM RCSFBLOCK ENDDO ENDIF - + CONTAINS !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -289,5 +289,5 @@ SUBROUTINE index(n,a,ldown,indx) ENDIF RETURN END SUBROUTINE - + END PROGRAM diff --git a/src/tool/rcsfmr.f90 b/src/tool/rcsfmr.f90 index 5f235b797..7a416f27b 100644 --- a/src/tool/rcsfmr.f90 +++ b/src/tool/rcsfmr.f90 @@ -15,7 +15,7 @@ program rcsfmr write(*,*) 'larger than a specified cut-off' write(*,*) 'Input file: namel.lsj.lbl' write(*,*) 'Ouput is written to screen' -write(*,*) +write(*,*) write(*,*) 'Name of state' read(*,'(a)') filename write(*,*) 'Give cut-off for weight' @@ -54,9 +54,9 @@ program rcsfmr end do end do -write(*,*) +write(*,*) write(*,*) 'Configurations in the MR' -write(*,*) +write(*,*) do i = 1,n if (len(trim(string_vec(i))).gt.0) then @@ -116,7 +116,7 @@ subroutine stringprocess(string1,string2) end if end do -! Now remove digits unless digit in parenthesis or if +! Now remove digits unless digit in parenthesis or if ! first or second character to the right is 's','p',.... string1 = ' ' @@ -215,7 +215,7 @@ subroutine stringprocess(string1,string2) end do !write(*,'(a)') trim(string2) - -end + +end diff --git a/src/tool/rcsfratip.f90 b/src/tool/rcsfratip.f90 index ffbc4e4fe..2f34e7a65 100644 --- a/src/tool/rcsfratip.f90 +++ b/src/tool/rcsfratip.f90 @@ -1,9 +1,9 @@ program rcsfratip -! Program to convert output format from grasp format to the +! Program to convert output format from grasp format to the ! format used by RATIP -! Written by Jorgen Ekman and Per Jonsson, December 2013 +! Written by Jorgen Ekman and Per Jonsson, December 2013 character(len=1000):: line1,line2,line3,line4,blankline integer :: i,m,ncorr @@ -38,7 +38,7 @@ program rcsfratip do do i = m,m-5,-1 if (line3(i:i).eq.' ') then - ncorr = 9*nint(real(i)/real(9)) ! Correct position of blank + ncorr = 9*nint(real(i)/real(9)) ! Correct position of blank line4(ncorr+1:ncorr+m-i) = line3(i+1:m) ! Move to correct position exit end if diff --git a/src/tool/rcsfsplit.f90 b/src/tool/rcsfsplit.f90 index 929dae5fc..b9b8229a2 100644 --- a/src/tool/rcsfsplit.f90 +++ b/src/tool/rcsfsplit.f90 @@ -18,12 +18,12 @@ program rcsfsplit write(*,*) 'per l-symmetry, in a comma delimited list in s,p,d etc order, e.g. 5s,4p,3d' write(*,*) 'Input file: name.c' write(*,*) 'Output files: namelabel1.c, namelabel2.c, ...' -write(*,*) +write(*,*) write(*,*) 'Name of state' read(*,'(a)') name -! Open file +! Open file open(unit=36,file=trim(name)//'.c',status='old') @@ -71,7 +71,7 @@ program rcsfsplit orbital(i) = " " // orbitalstring(jl:jr-1) else write(*,*) 'Orbitals should be given in comma delimited list, redo!' - goto 991 + goto 991 end if jl = jr + 1 i = i +1 @@ -81,15 +81,15 @@ program rcsfsplit if (len_trim(orbitalstring(jl:jr)).eq.3) then orbital(i) = orbitalstring(jl:jr) else if (len_trim(orbitalstring(jl:jr)).eq.2) then - orbital(i) = " " // orbitalstring(jl:jr) + orbital(i) = " " // orbitalstring(jl:jr) else write(*,*) 'Orbitals should be given in comma delimited list, redo!' - goto 991 + goto 991 end if norblayer = i -! For current orbital layer find out the compliment orbitals +! For current orbital layer find out the compliment orbitals norbcomp = 0 do i = 1,norb @@ -106,9 +106,9 @@ program rcsfsplit if (nsymmetrymatch.eq.0) then norbcomp = norbcomp + 1 orbcomp(norbcomp) = orb(i) - end if - end do - + end if + end do + rewind(36) read(36,'(a)') string1 write(48+k,'(a)') trim(string1) @@ -143,10 +143,10 @@ program rcsfsplit write(48+k,'(a)') trim(string1) ncsf = 0 - do + do read(36,'(a)',end=99) string1 if (string1(2:2).eq.'*') then - write(48+k,'(a)') trim(string1) + write(48+k,'(a)') trim(string1) read(36,'(a)') string1 end if read(36,'(a)') string2 @@ -160,9 +160,9 @@ program rcsfsplit if (n.ne.0) exit end do if (n.eq.0) then - write(48+k,'(a)') trim(string1) - write(48+k,'(a)') trim(string2) - write(48+k,'(a)') trim(string3) + write(48+k,'(a)') trim(string1) + write(48+k,'(a)') trim(string2) + write(48+k,'(a)') trim(string3) ncsf = ncsf + 1 end if end do @@ -181,4 +181,4 @@ program rcsfsplit end do end program rcsfsplit - + diff --git a/src/tool/rhfs_lsj.f90 b/src/tool/rhfs_lsj.f90 index a4c3ebf9c..421c94b16 100644 --- a/src/tool/rhfs_lsj.f90 +++ b/src/tool/rhfs_lsj.f90 @@ -6,14 +6,14 @@ PROGRAM rhfs_lsj ! and Lande g-factors. The program reads the LSJ classification * ! file for labeling purposes. ! * -! Per Jonsson and Gediminas Gaigalas * +! Per Jonsson and Gediminas Gaigalas * ! August 2011 * ! * !*********************************************************************** IMPLICIT NONE INTEGER, PARAMETER:: JMax = 22 ! max J value, see JFraction ! INTEGER, PARAMETER:: ndim = 20000 ! max number of states - INTEGER, PARAMETER:: maxFile = 1000 ! max number of files + INTEGER, PARAMETER:: maxFile = 1000 ! max number of files ! CHARACTER(LEN=80) strInFile(maxFile), strFile CHARACTER*1 iaspa(ndim), PlusMinus(-1:1),ans ! Parity @@ -64,16 +64,16 @@ PROGRAM rhfs_lsj WRITE(*,*) WRITE(*,*) 'Name of the state' - READ(*,*) strFile + READ(*,*) strFile K = INDEX(strFile,' ') WRITE(*,*) 'Hfs data from a CI calc?' READ(*,*) ans IF ((ans.eq.'y').or.(ans.eq.'Y')) THEN hfs_file = strFile(1:K-1)//'.ch' - output_file = strFile(1:K-1)//'.chlsj' + output_file = strFile(1:K-1)//'.chlsj' ELSE hfs_file = strFile(1:K-1)//'.h' - output_file = strFile(1:K-1)//'.hlsj' + output_file = strFile(1:K-1)//'.hlsj' END IF OPEN (30, FILE = hfs_file, FORM = 'FORMATTED', & STATUS = 'OLD', IOSTAT = IOS) @@ -102,7 +102,7 @@ PROGRAM rhfs_lsj ELSE nsort = 0 END IF - + CALL READHFS CALL LDLBL @@ -113,7 +113,7 @@ PROGRAM rhfs_lsj IZERO = 0 DO I = 1,IMaxCount IF (Lev_J(I).EQ.' 0') IZERO = IZERO + 1 - END DO + END DO DUMMY0 = ' ' DUMMY = DUMMY0//DUMMY0 @@ -148,7 +148,7 @@ PROGRAM rhfs_lsj Lev_Par(I+1) = SWAPP Lev_J(I+1) = SWAPJ string_CSF(I+1) = SWAPCSF - END DO + END DO END IF DO I = IZERO + 1,IMaxCount @@ -196,7 +196,7 @@ SUBROUTINE READHFS CHARACTER*120 RECORD DOUBLE PRECISION A(ndim),B(ndim),GJ(ndim) ! - COMMON/HFS/A,B,GJ + COMMON/HFS/A,B,GJ ! Position yourself at the correct place in the file @@ -204,7 +204,7 @@ SUBROUTINE READHFS READ (30,'(A)') RECORD WRITE(80,'(1X,A)') TRIM(RECORD) END DO - + DO READ (30,'(A)') RECORD @@ -223,7 +223,7 @@ SUBROUTINE READHFS !PJ WRITE(*,'(1P,3D20.10)') A(I),B(I),GJ(I) I = I + 1 END DO - 20 CONTINUE + 20 CONTINUE RETURN END @@ -259,7 +259,7 @@ SUBROUTINE LDLBL COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & IMaxCount, MAX_STRING_LENGTH ! - MAX_STRING_LENGTH = 0 + MAX_STRING_LENGTH = 0 READ (31,'(1A15)',IOSTAT = IOS) RECORD ICount = 0 @@ -273,7 +273,7 @@ SUBROUTINE LDLBL READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF(ICount) K = INDEX(string_CSF(ICount),' ') IF (K.GT.MAX_STRING_LENGTH) MAX_STRING_LENGTH = K - + ! 2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST IF (IOS .NE. 0) GO TO 1 diff --git a/src/tool/rlevels.f90 b/src/tool/rlevels.f90 index fb77b1c11..9f7923cd8 100644 --- a/src/tool/rlevels.f90 +++ b/src/tool/rlevels.f90 @@ -24,15 +24,15 @@ PROGRAM rlevelsj ! * ! Xinghong He 98-10-16 * ! * -! Rewritten by G. Gaigalas * -! for LSJ calssification of levels * +! Rewritten by G. Gaigalas * +! for LSJ calssification of levels * ! NIST May 2011 * ! * !*********************************************************************** IMPLICIT NONE INTEGER, PARAMETER:: JMax = 22 ! max J value, see JFraction ! INTEGER, PARAMETER:: ndim = 20000 ! max number of states - INTEGER, PARAMETER:: maxFile = 1000 ! max number of files + INTEGER, PARAMETER:: maxFile = 1000 ! max number of files DOUBLE PRECISION, PARAMETER:: Rydberg = 109737.31568508d0 ! CHARACTER(LEN=80) strInFile(maxFile), strFile @@ -53,7 +53,7 @@ PROGRAM rlevelsj DOUBLE PRECISION eav, eval(ndim), evec, RLev_ENER(ndim),ZERO ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! DATA PlusMinus/'-', ' ', '+'/ DATA JFraction/' 0 ', ' 1/2', ' 1 ', ' 3/2', ' 2 ', ' 5/2', & @@ -95,7 +95,7 @@ PROGRAM rlevelsj EXIT ENDIF ENDDO - mFile = i + mFile = i ELSEIF (mFile .GT. 0 .AND. mFile .LE. maxFile) THEN DO i = 1, mFile CALL getarg (i, strInFile(i)) @@ -116,7 +116,7 @@ PROGRAM rlevelsj , IOSTAT = IOS) IF (IOS .NE. 0) THEN WRITE (0,*) 'Failed to open file "', & - strFile(1:LEN_TRIM (strFile)), '", skipping...' + strFile(1:LEN_TRIM (strFile)), '", skipping...' CLOSE (3) CYCLE ENDIF @@ -136,7 +136,7 @@ PROGRAM rlevelsj READ (3) nb, ncfblk, nevblk, iiatjp, iiaspa IF (jblock .NE. nb) THEN ! -! This error can occur anywhere and therefore cannot +! This error can occur anywhere and therefore cannot ! be simply skipped - stop instead. ! WRITE (0,*) 'jblock .NE. nb, stopping...' @@ -174,7 +174,7 @@ PROGRAM rlevelsj OPEN (31, FILE = util_lbl_file, FORM = 'FORMATTED', & STATUS = 'OLD', IOSTAT = IOS) IF (IOS .NE. 0) THEN -!GG WRITE (0,*) 'Failed to open file "', +!GG WRITE (0,*) 'Failed to open file "', !GG & util_lbl_file(1:LEN_TRIM (util_lbl_file)), '", skipping...' CLOSE (31) CYCLE @@ -200,7 +200,7 @@ PROGRAM rlevelsj ! The output of the levels ! PRINT * - WRITE (6,1) + WRITE (6,1) WRITE (6,2) Rydberg if(Iprint .eq. 1) then WRITE (6,*) 'Splitting is the energy difference ', & @@ -215,13 +215,13 @@ PROGRAM rlevelsj i = indx(j) WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & ZERO,ZERO, & - Trim(string_PRN(i)) + Trim(string_PRN(i)) DO j = 2, ncountState i = indx(j) WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & (eval(i)-eval(indx(1)))*Rydberg*2, & (eval(i)-eval(indx(j-1)))*Rydberg*2, & - Trim(string_PRN(i)) + Trim(string_PRN(i)) END DO WRITE (6,5) ELSE @@ -345,7 +345,7 @@ SUBROUTINE LDLBL DOUBLE PRECISION RLev_ENER(ndim) ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! READ (31,'(1A15)',IOSTAT = IOS) RECORD ICount = 0 diff --git a/src/tool/rlevelseV.f90 b/src/tool/rlevelseV.f90 index 4bb075591..aeaea8b3d 100644 --- a/src/tool/rlevelseV.f90 +++ b/src/tool/rlevelseV.f90 @@ -24,15 +24,15 @@ PROGRAM rlevelsj ! * ! Xinghong He 98-10-16 * ! * -! Rewritten by G. Gaigalas * -! for LSJ calssification of levels * +! Rewritten by G. Gaigalas * +! for LSJ calssification of levels * ! NIST May 2011 * ! * !*********************************************************************** IMPLICIT NONE INTEGER, PARAMETER:: JMax = 22 ! max J value, see JFraction ! INTEGER, PARAMETER:: ndim = 20000 ! max number of states - INTEGER, PARAMETER:: maxFile = 1000 ! max number of files + INTEGER, PARAMETER:: maxFile = 1000 ! max number of files DOUBLE PRECISION, PARAMETER:: Rydberg = 109737.31568508d0 DOUBLE PRECISION, PARAMETER:: eV = 27.211386018D0 ! @@ -54,7 +54,7 @@ PROGRAM rlevelsj DOUBLE PRECISION eav, eval(ndim), evec, RLev_ENER(ndim),ZERO ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! DATA PlusMinus/'-', ' ', '+'/ DATA JFraction/' 0 ', ' 1/2', ' 1 ', ' 3/2', ' 2 ', ' 5/2', & @@ -96,7 +96,7 @@ PROGRAM rlevelsj EXIT ENDIF ENDDO - mFile = i + mFile = i ELSEIF (mFile .GT. 0 .AND. mFile .LE. maxFile) THEN DO i = 1, mFile CALL getarg (i, strInFile(i)) @@ -117,7 +117,7 @@ PROGRAM rlevelsj , IOSTAT = IOS) IF (IOS .NE. 0) THEN WRITE (0,*) 'Failed to open file "', & - strFile(1:LEN_TRIM (strFile)), '", skipping...' + strFile(1:LEN_TRIM (strFile)), '", skipping...' CLOSE (3) CYCLE ENDIF @@ -137,7 +137,7 @@ PROGRAM rlevelsj READ (3) nb, ncfblk, nevblk, iiatjp, iiaspa IF (jblock .NE. nb) THEN ! -! This error can occur anywhere and therefore cannot +! This error can occur anywhere and therefore cannot ! be simply skipped - stop instead. ! WRITE (0,*) 'jblock .NE. nb, stopping...' @@ -175,7 +175,7 @@ PROGRAM rlevelsj OPEN (31, FILE = util_lbl_file, FORM = 'FORMATTED', & STATUS = 'OLD', IOSTAT = IOS) IF (IOS .NE. 0) THEN -!GG WRITE (0,*) 'Failed to open file "', +!GG WRITE (0,*) 'Failed to open file "', !GG & util_lbl_file(1:LEN_TRIM (util_lbl_file)), '", skipping...' CLOSE (31) CYCLE @@ -201,7 +201,7 @@ PROGRAM rlevelsj ! The output of the levels ! PRINT * - WRITE (6,1) + WRITE (6,1) WRITE (6,2) Rydberg if(Iprint .eq. 1) then WRITE (6,*) 'Splitting is the energy difference ', & @@ -216,13 +216,13 @@ PROGRAM rlevelsj i = indx(j) WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & ZERO,ZERO, & - Trim(string_PRN(i)) + Trim(string_PRN(i)) DO j = 2, ncountState i = indx(j) WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & (eval(i)-eval(indx(1)))*eV, & (eval(i)-eval(indx(j-1)))*eV, & - Trim(string_PRN(i)) + Trim(string_PRN(i)) END DO WRITE (6,5) ELSE @@ -243,7 +243,7 @@ PROGRAM rlevelsj i = indx(j) WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & (eval(i)-eval(indx(1)))*eV, & - (eval(i)-eval(indx(j-1)))*eV + (eval(i)-eval(indx(j-1)))*eV END DO WRITE (6,6) END IF @@ -346,7 +346,7 @@ SUBROUTINE LDLBL DOUBLE PRECISION RLev_ENER(ndim) ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! READ (31,'(1A15)',IOSTAT = IOS) RECORD ICount = 0 diff --git a/src/tool/rmixaccumulate.f90 b/src/tool/rmixaccumulate.f90 index 320712d75..1f1f15a35 100644 --- a/src/tool/rmixaccumulate.f90 +++ b/src/tool/rmixaccumulate.f90 @@ -1,330 +1,330 @@ -program rmixaccumulate - implicit none - integer :: i,ii,j,jj,k,kk,l,ios,err - integer :: nelec, ncftot, nw, nvectot, nvecsize, nblock - integer :: nb, nevblk(100), iatjp, iaspa - integer :: ivec - integer :: nrelorb, indexans, co(100) - integer, allocatable :: checkcsf(:,:), ind(:,:), ind2(:,:), ncfblk(:) - integer, allocatable :: ncfblockout(:) - - double precision :: eav,eval - double precision :: dc2evec, totc2evecblk, c2evecblklim - double precision, allocatable :: evec(:,:,:),c2evec(:,:) - - character(len=100) :: state, file1, file2 - character(len=600) :: header(5), string - character(len=5) :: relorbitals(100) - character(len=6) :: G92MIX - character(len=1) :: ciflag,sortflag - character(len=100), allocatable :: conf(:,:), coupling(:,:), spin(:,:) - write(*,*) '***************************************************************************' - write(*,*) 'Welcome to program rmixaccumulate' - write(*,*) - write(*,*) 'The program accumulates dominating CSFs by mixing coefficients up to' - write(*,*) 'a user defined fraction of the total wave function.' - write(*,*) 'The CSFs in the output list can be sorted by mixing coefficents' - write(*,*) 'to provide better initial estimates for the subsequent diagonalisation.' - write(*,*) 'of CI matrices.' - write(*,*) - write(*,*) 'Input files: .(c)m, .c' - write(*,*) 'Output file: rcsf.out' - write(*,*) - write(*,*) ' J. Ekman & P. Jonsson Feb 2016' - write(*,*) '***************************************************************************' - - write(*,*) - write(*,*) 'Give name of the state: ' - read(*,*) state - write(*,*) 'Expansion coefficients resulting from CI calculation (y/n)? ' - read(*,*) ciflag - if(ciflag.ne.'y'.and.ciflag.ne.'n') then - write(*,*) 'Your input must be "y" or "n" (case sensitive). Try again!' - call exit() - end if - write(*,*) 'Fraction of total wave function [0-1] to be included in reduced list: ' - read(*,*) c2evecblklim - write(*,*) 'CSFs in output file sorted by mixing coefficients (y/n)? ' - read(*,*) sortflag - if(sortflag.ne.'y'.and.sortflag.ne.'n') then - write(*,*) 'Your input must be "y" or "n" (case sensitive). Try again!' - call exit() - end if - - l = index(state,' ') - if(ciflag.eq.'y') then - file1 = state(1:l-1)//'.cm' - else - file1 = state(1:l-1)//'.m' - end if - file2 = state(1:l-1)//'.c' - - ! Open and read data from mix file .(c)m - open (7,file=file1,status='old',form='unformatted') - read (7,iostat=ios) G92MIX - !write(*,*) G92MIX - read (7) nelec, ncftot, nw, nvectot, nvecsize, nblock - !write(*,*) ' nelec = ', nelec - !write(*,*) ' ncftot = ', ncftot - !write(*,*) ' nw = ', nw - !write(*,*) ' nblock = ', nblock - !write(*,*) - - ! Allocate various arrays - allocate( conf(nblock,ncftot) ) - allocate( coupling(nblock,ncftot) ) - allocate( spin(nblock,ncftot) ) - allocate( ncfblockout(nblock) ) - allocate( ncfblk(ncftot) ) - allocate( ind(nblock,ncftot), ind2(nblock,ncftot) ) - allocate( checkcsf(nblock,ncftot) ) - allocate( evec(nblock,100,ncftot), c2evec(nblock,ncftot) ) - - ! Continue to read data from mixing file .(c)m - ! Mixing coefficients are stored in 3D array: evec(block,eig,csf) - evec(:,:,:) = 0.d0 - write(*,*) - write(*,*) 'Block data read from mixing file' - write(*,*) ' block ncf nev 2j+1 parity' - do i=1, nblock - READ (7,end=98) nb, ncfblk(i), nevblk(i), iatjp, iaspa - write(*,*) nb, ncfblk(i), nevblk(i), iatjp, iaspa - if(nevblk(i).gt.0) then -! DO j = nvecpat + 1, nvecpat + nevblk(i) -! ! ivec(i) = ivec(i) + ncfpat ! serial # of the state -! iatjpo(j) = iatjp -! iaspar(j) = iaspa -! ENDDO - - read (7) (ivec, j = 1,nevblk(i)) - !write(*,*) ivec(nvecpat+j) - - read (7) eav, (eval, j = 1, nevblk(i)) - !write(*,*) eav - - read (7) ((evec(i,k,j), j = 1, ncfblk(i)), k = 1, nevblk(i)) - !write(*,*) evec(nvecsizpat + ncfpat+j + (k-1)*ncftot) - end if - !nvecpat = nvecpat + nevblk(i) - !ncfpat = ncfpat + ncfblk(i) - !nvecsizpat = nvecsizpat + nevblk(i)*ncftot - end do -98 continue - close(7) - - ! For each CSF, calculate the sum of square of expansion coefficents for eigenvalues - ! Block divided - c2evec(:,:) = 0.0 - !write(*,*) - do i=1,nblock - !do j=1,2 - do k=1,ncfblk(i) - do j=1,nevblk(i) - c2evec(i,k) = c2evec(i,k)+evec(i,j,k)**2.d0 - end do - c2evec(i,k) = c2evec(i,k)/dble(nevblk(i)) - !write(*,*) i, k, evec(i,1:nevblk(i),k),c2evec(i,k) - end do - !end do - end do - - ! Sort square of expansions coefficients (c2evec) and index table (ind) - ! Compute sum of square of expansion coefficients for each block - ! and "flag" CSF:s that contribute to user defined fraction of total wave functions - ! write(*,*) - checkcsf(:,:) = 0 - ind2(:,:) = 0 - do i = 1, nblock - - if (ncfblk(i).gt.1) then - call HPSORT(ncfblk(i),c2evec(i,1:ncfblk(i)),ind(i,1:ncfblk(i))) - end if - - do k=ncfblk(i),ncfblk(i)-nevblk(i)+1,-1 - kk = ncfblk(i) + 1 - k - ind2(i,kk) = ind(i,k) - if(sortflag.eq.'n') then - checkcsf(i,ind2(i,kk)) = 1 - else if(sortflag.eq.'y') then - checkcsf(i,kk) = 1 - end if - end do - - totc2evecblk = 0.d0 - do k=ncfblk(i),1,-1 - totc2evecblk = totc2evecblk + c2evec(i,k) - kk = ncfblk(i) + 1 - k - ind2(i,kk) = ind(i,k) - if(totc2evecblk.le.c2evecblklim) then - if(sortflag.eq.'n') then - checkcsf(i,ind2(i,kk)) = 1 - else if(sortflag.eq.'y') then - checkcsf(i,kk) = 1 - end if - end if - !write(*,*) k, kk, ind2(i,kk), c2evec(i,k), totc2evecblk, checkcsf(i,ind2(i,kk)) - !write(*,*) k, kk, ind2(i,kk), c2evec(i,k), totc2evecblk, checkcsf(i,kk) - end do - - end do - - ! Open and read data from input file .c - open (7,file=file2,status='unknown',form='formatted') - do j=1,5 - read(7,'(a)') header(j) - !write(*,*) trim(header(j)) - end do - - string = header(4) - ii = 1 - do -!cjb changed 'short if' into 'regular if' in rmixaccumulate.f90:181 - if(string((5*ii-3):(5*ii)).eq.' ') then - exit - endif - relorbitals(ii) = string((5*ii-3):(5*ii)) - ii = ii +1 - end do - nrelorb = ii - 1 - !write(*,*) 'nrelorb: ', nrelorb - - i = 1 - j = 1 - do - read(7,'(a)',end=99) string - if(string(2:2).eq.'*') then - !ncsf(i) = j - 1 - i = i + 1 - j = 1 - read(7,'(a)') conf(i,j) - else - conf(i,j) = string - end if - read(7,'(a)') coupling(i,j) - read(7,'(a)') spin(i,j) - j = j + 1 - end do -99 continue - close(7) - - ! Open output file rcsf.out and write reduced CSF list - co(:) = 0 - ncfblockout(:) = 0 - open (10,file='rcsf.out',status='unknown',form='formatted') - do j=1,5 - write(10,'(a)') trim(header(j)) - end do - do i = 1, nblock - do j=1, ncfblk(i) - if((checkcsf(i,j).eq.1).or.(ncfblk(i).eq.1)) then ! PJ Treat also special case with 1 CSF - ncfblockout(i) = ncfblockout(i) + 1 - !write(10,'(i10,i10)') j,ind2(i,j) - if(sortflag.eq.'n') then - write(10,'(a)') trim(conf(i,j)) - - if(sum(co(1:nrelorb)).lt.nrelorb) then - do ii=1,nrelorb - indexans = index(conf(i,j),relorbitals(ii)(1:4)) - if(indexans > 0) then - co(ii) = 1 - end if - end do - end if - - write(10,'(a)') trim(coupling(i,j)) - write(10,'(a)') trim(spin(i,j)) - else if(sortflag.eq.'y') then - write(10,'(a)') trim(conf(i,ind2(i,j))) - - if(sum(co(1:nrelorb)).lt.nrelorb) then - do ii=1,nrelorb - indexans = index(conf(i,ind2(i,j)),relorbitals(ii)(1:4)) - if(indexans > 0) then - co(ii) = 1 - end if - end do - end if - - write(10,'(a)') trim(coupling(i,ind2(i,j))) - write(10,'(a)') trim(spin(i,ind2(i,j))) - end if - end if - end do - if(i.lt.nblock) write(10,'(a2)') ' *' - end do - close(10) - - - ! Print information of reduced list - write(*,*) - write(*,*) 'Number of CSF:s written to rcsf.out' - write(*,*) ' block ncf' - do i = 1, nblock - write(*,*) i, ncfblockout(i) - end do - - if(sum(co(1:nrelorb)).lt.nrelorb) then - write(*,*) - write(*,*) 'WARNING! Not all peel subshells are occupied in the output CSF list: ' - write(*,*) 'Remove the following peel subshells: ' - do i = 1, nrelorb - if(co(i).lt.1) then - write(*,*) relorbitals(i) - end if - end do - end if - - -end program rmixaccumulate - -SUBROUTINE HPSORT(N,RA,IND) - integer N,IND(N),L,IR,I,J - double precision RA(N), RRA - - L=N/2+1 - IR=N - do I=1,N - IND(I) = I - end do - - !The index L will be decremented from its initial value during the - !"hiring" (heap creation) phase. Once it reaches 1, the index IR - !will be decremented from its initial value down to 1 during the - !"retirement-and-promotion" (heap selection) phase. -10 continue - if(L > 1)then - L=L-1 - RRA=RA(L) - IRRA = IND(L) ! je - else - RRA=RA(IR) - IRRA = IND(IR) ! je - RA(IR)=RA(1) - IND(IR)=IND(1) !je - IR=IR-1 - if(IR.eq.1)then - RA(1)=RRA - IND(1)=IRRA !je - return - end if - end if - I=L - J=L+L -20 if(J.le.IR)then - if(J < IR)then - if(RA(J) < RA(J+1)) J=J+1 - end if - if(RRA < RA(J))then - RA(I)=RA(J) - IND(I)=IND(J) !je - I=J; J=J+J - else - J=IR+1 - end if - - goto 20 - end if - RA(I)=RRA - IND(I)=IRRA - goto 10 -END +program rmixaccumulate + implicit none + integer :: i,ii,j,jj,k,kk,l,ios,err + integer :: nelec, ncftot, nw, nvectot, nvecsize, nblock + integer :: nb, nevblk(100), iatjp, iaspa + integer :: ivec + integer :: nrelorb, indexans, co(100) + integer, allocatable :: checkcsf(:,:), ind(:,:), ind2(:,:), ncfblk(:) + integer, allocatable :: ncfblockout(:) + + double precision :: eav,eval + double precision :: dc2evec, totc2evecblk, c2evecblklim + double precision, allocatable :: evec(:,:,:),c2evec(:,:) + + character(len=100) :: state, file1, file2 + character(len=600) :: header(5), string + character(len=5) :: relorbitals(100) + character(len=6) :: G92MIX + character(len=1) :: ciflag,sortflag + character(len=100), allocatable :: conf(:,:), coupling(:,:), spin(:,:) + write(*,*) '***************************************************************************' + write(*,*) 'Welcome to program rmixaccumulate' + write(*,*) + write(*,*) 'The program accumulates dominating CSFs by mixing coefficients up to' + write(*,*) 'a user defined fraction of the total wave function.' + write(*,*) 'The CSFs in the output list can be sorted by mixing coefficents' + write(*,*) 'to provide better initial estimates for the subsequent diagonalisation.' + write(*,*) 'of CI matrices.' + write(*,*) + write(*,*) 'Input files: .(c)m, .c' + write(*,*) 'Output file: rcsf.out' + write(*,*) + write(*,*) ' J. Ekman & P. Jonsson Feb 2016' + write(*,*) '***************************************************************************' + + write(*,*) + write(*,*) 'Give name of the state: ' + read(*,*) state + write(*,*) 'Expansion coefficients resulting from CI calculation (y/n)? ' + read(*,*) ciflag + if(ciflag.ne.'y'.and.ciflag.ne.'n') then + write(*,*) 'Your input must be "y" or "n" (case sensitive). Try again!' + call exit() + end if + write(*,*) 'Fraction of total wave function [0-1] to be included in reduced list: ' + read(*,*) c2evecblklim + write(*,*) 'CSFs in output file sorted by mixing coefficients (y/n)? ' + read(*,*) sortflag + if(sortflag.ne.'y'.and.sortflag.ne.'n') then + write(*,*) 'Your input must be "y" or "n" (case sensitive). Try again!' + call exit() + end if + + l = index(state,' ') + if(ciflag.eq.'y') then + file1 = state(1:l-1)//'.cm' + else + file1 = state(1:l-1)//'.m' + end if + file2 = state(1:l-1)//'.c' + + ! Open and read data from mix file .(c)m + open (7,file=file1,status='old',form='unformatted') + read (7,iostat=ios) G92MIX + !write(*,*) G92MIX + read (7) nelec, ncftot, nw, nvectot, nvecsize, nblock + !write(*,*) ' nelec = ', nelec + !write(*,*) ' ncftot = ', ncftot + !write(*,*) ' nw = ', nw + !write(*,*) ' nblock = ', nblock + !write(*,*) + + ! Allocate various arrays + allocate( conf(nblock,ncftot) ) + allocate( coupling(nblock,ncftot) ) + allocate( spin(nblock,ncftot) ) + allocate( ncfblockout(nblock) ) + allocate( ncfblk(ncftot) ) + allocate( ind(nblock,ncftot), ind2(nblock,ncftot) ) + allocate( checkcsf(nblock,ncftot) ) + allocate( evec(nblock,100,ncftot), c2evec(nblock,ncftot) ) + + ! Continue to read data from mixing file .(c)m + ! Mixing coefficients are stored in 3D array: evec(block,eig,csf) + evec(:,:,:) = 0.d0 + write(*,*) + write(*,*) 'Block data read from mixing file' + write(*,*) ' block ncf nev 2j+1 parity' + do i=1, nblock + READ (7,end=98) nb, ncfblk(i), nevblk(i), iatjp, iaspa + write(*,*) nb, ncfblk(i), nevblk(i), iatjp, iaspa + if(nevblk(i).gt.0) then +! DO j = nvecpat + 1, nvecpat + nevblk(i) +! ! ivec(i) = ivec(i) + ncfpat ! serial # of the state +! iatjpo(j) = iatjp +! iaspar(j) = iaspa +! ENDDO + + read (7) (ivec, j = 1,nevblk(i)) + !write(*,*) ivec(nvecpat+j) + + read (7) eav, (eval, j = 1, nevblk(i)) + !write(*,*) eav + + read (7) ((evec(i,k,j), j = 1, ncfblk(i)), k = 1, nevblk(i)) + !write(*,*) evec(nvecsizpat + ncfpat+j + (k-1)*ncftot) + end if + !nvecpat = nvecpat + nevblk(i) + !ncfpat = ncfpat + ncfblk(i) + !nvecsizpat = nvecsizpat + nevblk(i)*ncftot + end do +98 continue + close(7) + + ! For each CSF, calculate the sum of square of expansion coefficents for eigenvalues + ! Block divided + c2evec(:,:) = 0.0 + !write(*,*) + do i=1,nblock + !do j=1,2 + do k=1,ncfblk(i) + do j=1,nevblk(i) + c2evec(i,k) = c2evec(i,k)+evec(i,j,k)**2.d0 + end do + c2evec(i,k) = c2evec(i,k)/dble(nevblk(i)) + !write(*,*) i, k, evec(i,1:nevblk(i),k),c2evec(i,k) + end do + !end do + end do + + ! Sort square of expansions coefficients (c2evec) and index table (ind) + ! Compute sum of square of expansion coefficients for each block + ! and "flag" CSF:s that contribute to user defined fraction of total wave functions + ! write(*,*) + checkcsf(:,:) = 0 + ind2(:,:) = 0 + do i = 1, nblock + + if (ncfblk(i).gt.1) then + call HPSORT(ncfblk(i),c2evec(i,1:ncfblk(i)),ind(i,1:ncfblk(i))) + end if + + do k=ncfblk(i),ncfblk(i)-nevblk(i)+1,-1 + kk = ncfblk(i) + 1 - k + ind2(i,kk) = ind(i,k) + if(sortflag.eq.'n') then + checkcsf(i,ind2(i,kk)) = 1 + else if(sortflag.eq.'y') then + checkcsf(i,kk) = 1 + end if + end do + + totc2evecblk = 0.d0 + do k=ncfblk(i),1,-1 + totc2evecblk = totc2evecblk + c2evec(i,k) + kk = ncfblk(i) + 1 - k + ind2(i,kk) = ind(i,k) + if(totc2evecblk.le.c2evecblklim) then + if(sortflag.eq.'n') then + checkcsf(i,ind2(i,kk)) = 1 + else if(sortflag.eq.'y') then + checkcsf(i,kk) = 1 + end if + end if + !write(*,*) k, kk, ind2(i,kk), c2evec(i,k), totc2evecblk, checkcsf(i,ind2(i,kk)) + !write(*,*) k, kk, ind2(i,kk), c2evec(i,k), totc2evecblk, checkcsf(i,kk) + end do + + end do + + ! Open and read data from input file .c + open (7,file=file2,status='unknown',form='formatted') + do j=1,5 + read(7,'(a)') header(j) + !write(*,*) trim(header(j)) + end do + + string = header(4) + ii = 1 + do +!cjb changed 'short if' into 'regular if' in rmixaccumulate.f90:181 + if(string((5*ii-3):(5*ii)).eq.' ') then + exit + endif + relorbitals(ii) = string((5*ii-3):(5*ii)) + ii = ii +1 + end do + nrelorb = ii - 1 + !write(*,*) 'nrelorb: ', nrelorb + + i = 1 + j = 1 + do + read(7,'(a)',end=99) string + if(string(2:2).eq.'*') then + !ncsf(i) = j - 1 + i = i + 1 + j = 1 + read(7,'(a)') conf(i,j) + else + conf(i,j) = string + end if + read(7,'(a)') coupling(i,j) + read(7,'(a)') spin(i,j) + j = j + 1 + end do +99 continue + close(7) + + ! Open output file rcsf.out and write reduced CSF list + co(:) = 0 + ncfblockout(:) = 0 + open (10,file='rcsf.out',status='unknown',form='formatted') + do j=1,5 + write(10,'(a)') trim(header(j)) + end do + do i = 1, nblock + do j=1, ncfblk(i) + if((checkcsf(i,j).eq.1).or.(ncfblk(i).eq.1)) then ! PJ Treat also special case with 1 CSF + ncfblockout(i) = ncfblockout(i) + 1 + !write(10,'(i10,i10)') j,ind2(i,j) + if(sortflag.eq.'n') then + write(10,'(a)') trim(conf(i,j)) + + if(sum(co(1:nrelorb)).lt.nrelorb) then + do ii=1,nrelorb + indexans = index(conf(i,j),relorbitals(ii)(1:4)) + if(indexans > 0) then + co(ii) = 1 + end if + end do + end if + + write(10,'(a)') trim(coupling(i,j)) + write(10,'(a)') trim(spin(i,j)) + else if(sortflag.eq.'y') then + write(10,'(a)') trim(conf(i,ind2(i,j))) + + if(sum(co(1:nrelorb)).lt.nrelorb) then + do ii=1,nrelorb + indexans = index(conf(i,ind2(i,j)),relorbitals(ii)(1:4)) + if(indexans > 0) then + co(ii) = 1 + end if + end do + end if + + write(10,'(a)') trim(coupling(i,ind2(i,j))) + write(10,'(a)') trim(spin(i,ind2(i,j))) + end if + end if + end do + if(i.lt.nblock) write(10,'(a2)') ' *' + end do + close(10) + + + ! Print information of reduced list + write(*,*) + write(*,*) 'Number of CSF:s written to rcsf.out' + write(*,*) ' block ncf' + do i = 1, nblock + write(*,*) i, ncfblockout(i) + end do + + if(sum(co(1:nrelorb)).lt.nrelorb) then + write(*,*) + write(*,*) 'WARNING! Not all peel subshells are occupied in the output CSF list: ' + write(*,*) 'Remove the following peel subshells: ' + do i = 1, nrelorb + if(co(i).lt.1) then + write(*,*) relorbitals(i) + end if + end do + end if + + +end program rmixaccumulate + +SUBROUTINE HPSORT(N,RA,IND) + integer N,IND(N),L,IR,I,J + double precision RA(N), RRA + + L=N/2+1 + IR=N + do I=1,N + IND(I) = I + end do + + !The index L will be decremented from its initial value during the + !"hiring" (heap creation) phase. Once it reaches 1, the index IR + !will be decremented from its initial value down to 1 during the + !"retirement-and-promotion" (heap selection) phase. +10 continue + if(L > 1)then + L=L-1 + RRA=RA(L) + IRRA = IND(L) ! je + else + RRA=RA(IR) + IRRA = IND(IR) ! je + RA(IR)=RA(1) + IND(IR)=IND(1) !je + IR=IR-1 + if(IR.eq.1)then + RA(1)=RRA + IND(1)=IRRA !je + return + end if + end if + I=L + J=L+L +20 if(J.le.IR)then + if(J < IR)then + if(RA(J) < RA(J+1)) J=J+1 + end if + if(RRA < RA(J))then + RA(I)=RA(J) + IND(I)=IND(J) !je + I=J; J=J+J + else + J=IR+1 + end if + + goto 20 + end if + RA(I)=RRA + IND(I)=IRRA + goto 10 +END diff --git a/src/tool/rmixextract.f90 b/src/tool/rmixextract.f90 index e32409bc5..cb8109dfc 100644 --- a/src/tool/rmixextract.f90 +++ b/src/tool/rmixextract.f90 @@ -1,7 +1,7 @@ PROGRAM extmix ! ! Extract mixing coefficients and the CSF from files -! .c, .m / .cm +! .c, .m / .cm USE iounit_C @@ -146,8 +146,8 @@ PROGRAM extmix IF (nevblk .LE. 0) GOTO 432 - - Allocate (eval(1:nevblk), stat=ierr) + + Allocate (eval(1:nevblk), stat=ierr) IF (ierr /= 0) STOP " not enough memory for eval" Allocate (evec(1:nevblk*ncfblk), stat=ierr) IF (ierr /= 0) STOP " not enough memory for evec" @@ -234,7 +234,7 @@ PROGRAM extmix 321 CONTINUE IF (jblock .LT. nblock) WRITE (nfout,'(A)') ' *' - + deallocate(iset) deallocate(eval) deallocate(evec) diff --git a/src/tool/rsave b/src/tool/rsave old mode 100755 new mode 100644 diff --git a/src/tool/rseqenergy.f90 b/src/tool/rseqenergy.f90 index 086066b5f..354138635 100644 --- a/src/tool/rseqenergy.f90 +++ b/src/tool/rseqenergy.f90 @@ -1,6 +1,6 @@ program rseqenergy -! Per Jönsson, Malmö University, June 2015 +! Per Jönsson, Malmö University, June 2015 implicit none logical :: ex @@ -19,10 +19,10 @@ program rseqenergy write(*,*) 'RSEQENERGY' write(*,*) 'This program reads output from rlevels for several' write(*,*) 'ions and produces a Matlab/Octave file that plots' -write(*,*) 'energy as a function of Z' +write(*,*) 'energy as a function of Z' write(*,*) 'Input files: energyZ1, energyZ2, .., energyZn' write(*,*) 'Output file: seqenergyplot.m' -write(*,*) +write(*,*) !--- Define Z range -------------------------- @@ -32,12 +32,12 @@ program rseqenergy !--- Give parity, J and number for state ----- write(*,*) 'How many states do you want to plot?' -read(*,*) nplot +read(*,*) nplot do i = 1,nplot write(*,*) 'Give number within symmetry,2*J and parity (+/-)' read(*,*) numplot(i),j2,pplot(i) - if (mod(j2,2).eq.0) then + if (mod(j2,2).eq.0) then if (j2.le.18) then write(jplot(i),'(a2,i1,a1)') ' ',j2/2,' ' else @@ -49,7 +49,7 @@ program rseqenergy else write(jplot(i),'(i2,a2)') j2,'/2' end if - end if + end if ! write(*,*) pplot(i),jplot(i),numplot(i) end do @@ -96,12 +96,12 @@ program rseqenergy i = 0 j = 0 - do + do read(100+k,'(a)',end=9) string j = j + 1 if (string.eq.'-----') then i = i + 1 - if (i.eq.2) then + if (i.eq.2) then nstart = j end if end if @@ -119,7 +119,7 @@ program rseqenergy !--- Read header information --------------- do i = 1,nstart - read(100+k,*) + read(100+k,*) end do !--- Read and xxxx @@ -159,20 +159,20 @@ program rseqenergy write(12,'(a)') 'AD = [z.^(-2) z.^(-1) z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'eiplsq = a(1)./zip.^2 + a(2)./zip + a(3) + a(4)*zip + a(5)*zip.^2 + a(6)*zip.^3;' write(12,'(a)') 'eiplsq = s*eiplsq + m;' - write(12,'(a)') "plot(zip,eiplsq,'r')" + write(12,'(a)') "plot(zip,eiplsq,'r')" write(12,*) else write(12,'(a)') 'z = A(:,1);' write(12,'(a)') 'AD = [z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'eiplsq = a(1) + a(2)*zip + a(3)*zip.^2 + a(4)*zip.^3;' write(12,'(a)') 'eiplsq = s*eiplsq + m;' - write(12,'(a)') "plot(zip,eiplsq,'r')" + write(12,'(a)') "plot(zip,eiplsq,'r')" write(12,*) end if else @@ -182,6 +182,6 @@ program rseqenergy end if end do -3 format(2i3,1x,a4,1x,a1,2x,f14.7,f12.2,f12.2,2x,a) +3 format(2i3,1x,a4,1x,a1,2x,f14.7,f12.2,f12.2,2x,a) end program rseqenergy diff --git a/src/tool/rseqhfs.f90 b/src/tool/rseqhfs.f90 index 877988e98..ac56afc09 100644 --- a/src/tool/rseqhfs.f90 +++ b/src/tool/rseqhfs.f90 @@ -1,6 +1,6 @@ program rseqhfs -! Per Jönsson, Malmö University, June 2015 +! Per Jönsson, Malmö University, June 2015 implicit none logical :: ex @@ -17,10 +17,10 @@ program rseqhfs write(*,*) 'RSEQHFS' write(*,*) 'This program reads output from rhfs for several' write(*,*) 'ions and produces a Matlab/Octave file that ' -write(*,*) 'plots hfs parameters as functions of Z' +write(*,*) 'plots hfs parameters as functions of Z' write(*,*) 'Input files: hfsZ1, hfsZ2, .., hfsZn or' write(*,*) 'Output file: seqhfsplot.m' -write(*,*) +write(*,*) !--- Define Z range -------------------------- @@ -30,12 +30,12 @@ program rseqhfs !--- Give parity, J and number for state ----- write(*,*) 'How many states do you want to plot?' -read(*,*) nplot +read(*,*) nplot do i = 1,nplot write(*,*) 'Give number within symmetry,2*J and parity (+/-)' read(*,*) numplot(i),j2,pplot(i) - if (mod(j2,2).eq.0) then + if (mod(j2,2).eq.0) then if (j2.le.18) then write(jplot(i),'(a3,i1)') ' ',j2/2 else @@ -47,7 +47,7 @@ program rseqhfs else write(jplot(i),'(i2,a2)') j2,'/2' end if - end if + end if ! write(*,*) pplot(i),jplot(i),numplot(i) end do @@ -96,17 +96,17 @@ program rseqhfs !--- Read header information --------------- do i = 1,9 - read(100+k,'(a)') + read(100+k,'(a)') end do !--- Read and xxxx nfound = 0 - do + do read(100+k,3,iostat=readerr) pos,jval,par,A,B,gJ if (readerr.ne.0) then exit - end if + end if ! write(*,3) pos,jval,par,A,B,gJ do j = 1,nplot if ((pplot(j).eq.par).and.(jplot(j).eq.jval).and.(numplot(j).eq.pos)) then @@ -141,7 +141,7 @@ program rseqhfs else write(12,'(a)') "ylabel('g_J')" end if - + do i = 1,nplot write(12,'(a,i2,a)') "plot(A(:,1),A(:,",i+1,"),'+')" write(12,*) @@ -151,20 +151,20 @@ program rseqhfs write(12,'(a)') 'AD = [z.^(-2) z.^(-1) z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'eiplsq = a(1)./zip.^2 + a(2)./zip + a(3) + a(4)*zip + a(5)*zip.^2 + a(6)*zip.^3;' write(12,'(a)') 'eiplsq = s*eiplsq + m;' - write(12,'(a)') "plot(zip,eiplsq,'r')" + write(12,'(a)') "plot(zip,eiplsq,'r')" write(12,*) else write(12,'(a)') 'z = A(:,1);' write(12,'(a)') 'AD = [z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'eiplsq = a(1) + a(2)*zip + a(3)*zip.^2 + a(4)*zip.^3;' write(12,'(a)') 'eiplsq = s*eiplsq + m;' - write(12,'(a)') "plot(zip,eiplsq,'r')" + write(12,'(a)') "plot(zip,eiplsq,'r')" write(12,*) end if else @@ -174,6 +174,6 @@ program rseqhfs end if end do -3 format(i4,5x,a4,1x,a1,2x,1P,3D20.10) +3 format(i4,5x,a4,1x,a1,2x,1P,3D20.10) end program rseqhfs diff --git a/src/tool/rseqtrans.f90 b/src/tool/rseqtrans.f90 index da87484ef..f95b212bb 100644 --- a/src/tool/rseqtrans.f90 +++ b/src/tool/rseqtrans.f90 @@ -1,6 +1,6 @@ program rseqtrans -! Per Jönsson, Malmö University, June 2015 +! Per Jönsson, Malmö University, June 2015 implicit none logical :: ex @@ -19,10 +19,10 @@ program rseqtrans write(*,*) 'RSEQTRANS' write(*,*) 'This program reads output from rtransition for several' write(*,*) 'ions and produces a Matlab/Octave file that plots' -write(*,*) 'A, gf, or S as a function of Z' +write(*,*) 'A, gf, or S as a function of Z' write(*,*) 'Input files: transZ1, transZ2, .., transZn' write(*,*) 'Output file: seqtransplot.m' -write(*,*) +write(*,*) !--- Define Z range -------------------------- @@ -45,13 +45,13 @@ program rseqtrans end if write(*,*) 'How many transitions do you want to plot?' -read(*,*) nplot +read(*,*) nplot do i = 1,nplot write(*,*) 'Give number within symmetry,2*J and parity (+/-)' write(*,*) 'for upper and lower state' read(*,*) numplotu(i),j2u,pplotu(i),numplotl(i),j2l,pplotl(i) - if (mod(j2u,2).eq.0) then + if (mod(j2u,2).eq.0) then if (j2u.le.18) then write(jplotu(i),'(a3,i1)') ' ',j2u/2 else @@ -63,8 +63,8 @@ program rseqtrans else write(jplotu(i),'(i2,a2)') j2u,'/2' end if - end if - if (mod(j2l,2).eq.0) then + end if + if (mod(j2l,2).eq.0) then if (j2l.le.18) then write(jplotl(i),'(a3,i1)') ' ',j2l/2 else @@ -76,7 +76,7 @@ program rseqtrans else write(jplotl(i),'(i2,a2)') j2l,'/2' end if - end if + end if ! write(*,*) pplotu(i),jplotu(i),numplotu(i) ! write(*,*) pplotl(i),jplotl(i),numplotl(i) @@ -150,25 +150,25 @@ program rseqtrans do read(100+k,300,iostat=readerr) f1,posu,jvalu,paru,f2,posl, & ! read(100+k,300) f1,posu,jvalu,paru,f2,posl, & - jvall,parl,elev,gauge,A,gf,S + jvall,parl,elev,gauge,A,gf,S if (readerr.ne.0) then exit - end if + end if if ((mp.eq.'E1').or.(mp.eq.'E2')) then - read(100+k,301) gauge,A,gf,S + read(100+k,301) gauge,A,gf,S end if ! write(*,300) f1,posu,jvalu,paru,f2,posl, & -! jvall,parl,elev,gauge,A,gf,S -! write(*,301) gauge,A,gf,S +! jvall,parl,elev,gauge,A,gf,S +! write(*,301) gauge,A,gf,S do j = 1,nplot if ((pplotu(j).eq.paru).and.(jplotu(j).eq.jvalu).and.(numplotu(j).eq.posu).and. & - (pplotl(j).eq.parl).and.(jplotl(j).eq.jvall).and.(numplotl(j).eq.posl)) then + (pplotl(j).eq.parl).and.(jplotl(j).eq.jvall).and.(numplotl(j).eq.posl)) then if (nform.eq.1) then transplot(j) = A elseif (nform.eq.2) then transplot(j) = gf - else + else transplot(j) = S end if nfound = nfound + 1 @@ -176,7 +176,7 @@ program rseqtrans end do end do -98 continue +98 continue if (nfound.ne.nplot) then write(*,*) 'Specified states not found in all lists' @@ -210,20 +210,20 @@ program rseqtrans write(12,'(a)') 'AD = [z.^(-2) z.^(-1) z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'aiplsq = a(1)./zip.^2 + a(2)./zip + a(3) + a(4)*zip + a(5)*zip.^2 + a(6)*zip.^3;' write(12,'(a)') 'aiplsq = s*aiplsq + m;' - write(12,'(a)') "plot(zip,aiplsq,'r')" + write(12,'(a)') "plot(zip,aiplsq,'r')" write(12,*) else write(12,'(a)') 'z = A(:,1);' write(12,'(a)') 'AD = [z.^0 z.^1 z.^2 z.^3];' write(12,'(a,i2,a)') 'y = A(:,',i+1,');' write(12,'(a)') 'm = mean(y); s = std(y);' - write(12,'(a)') 'a = AD\(y-m)/s' + write(12,'(a)') 'a = AD\(y-m)/s' write(12,'(a)') 'aiplsq = a(1) + a(2)*zip + a(3)*zip.^2 + a(4)*zip.^3;' write(12,'(a)') 'aiplsq = s*aiplsq + m;' - write(12,'(a)') "plot(zip,aiplsq,'r')" + write(12,'(a)') "plot(zip,aiplsq,'r')" write(12,*) end if else @@ -237,4 +237,4 @@ program rseqtrans 301 FORMAT(42X,A2,1P,3D13.5) end program rseqtrans - + diff --git a/src/tool/rtabhfs.f90 b/src/tool/rtabhfs.f90 index 4b5eadfa3..ed3c14fdd 100644 --- a/src/tool/rtabhfs.f90 +++ b/src/tool/rtabhfs.f90 @@ -4,7 +4,7 @@ PROGRAM RTABHFS ! * ! This program reads the output from rhfs_lsj and ris_lsj * -! and produces LaTeX tables of hfs and isdata * +! and produces LaTeX tables of hfs and isdata * ! * ! Written by Per Jonsson, Malmo University, May 2015 * ! * @@ -45,9 +45,9 @@ PROGRAM RTABHFS BLANKSTRING(I:I) = ' ' END DO -!---- Define input files --------------------------------------------- +!---- Define input files --------------------------------------------- - write(*,*) + write(*,*) ! WRITE(*,'(A)') ' HFS data (1), IS data (2), HFS and IS data (3)' ! READ(*,*) N N = 1 @@ -84,21 +84,21 @@ PROGRAM RTABHFS END DO END IF - write(*,*) + write(*,*) write(*,*) ' Inspect the name.(c)hlsj files and ' write(*,*) ' determine how many positions should be skipped in ' write(*,*) ' the string that determines the label. For example' write(*,*) ' if the string is 1s(2).2s_2S.2p(2)3P2_4P and 1s(2) ' write(*,*) ' is a core then you want to skip 1s(2). i.e. 6' write(*,*) ' positions' - write(*,*) + write(*,*) write(*,*) ' How many positions should be skipped?' read(*,*) NSKIP -!----- See write up for RIS for units ------------------------------ +!----- See write up for RIS for units ------------------------------ -!---- Start by analyzing all the RIS files to see that if they contain +!---- Start by analyzing all the RIS files to see that if they contain ! consistent data: DENS or F0CORR NF0CORR = 0 @@ -107,8 +107,8 @@ PROGRAM RTABHFS DO I = 1,M DO READ(80+I,'(A)',END=97) RECORD - IF (INDEX(RECORD,'F0CORR').GT.0) THEN - NF0CORR = NF0CORR + 1 + IF (INDEX(RECORD,'F0CORR').GT.0) THEN + NF0CORR = NF0CORR + 1 END IF END DO @@ -128,7 +128,7 @@ PROGRAM RTABHFS write(12,'(A)') '\documentclass[10pt]{article}' write(12,'(A)') '\usepackage{longtable}' - write(12,'(A)') '\begin{document}' + write(12,'(A)') '\begin{document}' IF (N.EQ.1) THEN WRITE(12,'(A)') '\begin{longtable}{lrrrr} \hline' WRITE(12,'(A)') 'State & $E$(a.u.) & $A$(MHz) & $B$(MHz) & ' @@ -172,7 +172,7 @@ PROGRAM RTABHFS READ(NUNIT+I,*) READ(NUNIT+I,*) END IF - READ(NUNIT+I,'(A)') STRINGANALYZE + READ(NUNIT+I,'(A)') STRINGANALYZE ! WRITE(*,*) TRIM(STRINGANALYZE) K = 1 DO @@ -222,7 +222,7 @@ PROGRAM RTABHFS ! WRITE(*,*) NUNIT,'PPOS',PPOS - DO + DO READ(NUNIT+I,405,IOSTAT=IEND) ENERGY1(J),STRING1(J) PSTRING1(J) = STRING1(J)(PPOS:PPOS) ! WRITE(*,*) PSTRING1(J),PPOS ! @@ -240,7 +240,7 @@ PROGRAM RTABHFS END DO 99 CONTINUE END DO - + NCOUNT1 = J - 1 ! WRITE(*,*) NCOUNT1 @@ -290,7 +290,7 @@ PROGRAM RTABHFS READ(NUNIT+I,*) READ(NUNIT+I,*) END IF - READ(NUNIT+I,'(A)') STRINGANALYZE + READ(NUNIT+I,'(A)') STRINGANALYZE ! WRITE(*,*) TRIM(STRINGANALYZE) K = 1 DO @@ -338,7 +338,7 @@ PROGRAM RTABHFS ! WRITE(*,*) 'BPOS',BPOS BPOS = BPOS - 17 - DO + DO READ(NUNIT+I,405,IOSTAT=IEND) ENERGY1(J),STRING1(J) PSTRING1(J) = STRING1(J)(PPOS:PPOS) JSTRING1(J) = STRING1(J)(JPOS-3:JPOS) @@ -368,7 +368,7 @@ PROGRAM RTABHFS READ(NUNIT+I,*) READ(NUNIT+I,*) READ(NUNIT+I,*) - READ(NUNIT+I,'(A)') STRINGANALYZE + READ(NUNIT+I,'(A)') STRINGANALYZE ! WRITE(*,*) TRIM(STRINGANALYZE) K = 1 DO @@ -416,7 +416,7 @@ PROGRAM RTABHFS ! WRITE(*,*) 'BPOS',BPOS BPOS = BPOS - 17 - DO + DO READ(NUNIT+I,405,IOSTAT=IEND) ENERGY2(J),STRING2(J) PSTRING2(J) = STRING2(J)(PPOS:PPOS) JSTRING2(J) = STRING2(J)(JPOS-3:JPOS) @@ -433,7 +433,7 @@ PROGRAM RTABHFS NCOUNT2 = J - 1 ! WRITE(*,*) NCOUNT2 - + !---- Now, sort all the energies from the iso file ---------------- @@ -478,7 +478,7 @@ PROGRAM RTABHFS END IF WRITE(12,'(A)') '\hline\\' - IF (N.EQ.1) THEN + IF (N.EQ.1) THEN WRITE(12,'(A)') '\caption{Hyperfine interaction constants}' ELSEIF (N.EQ.2) THEN WRITE(12,'(A)') '\caption{Isotope shift parameters}' @@ -488,8 +488,8 @@ PROGRAM RTABHFS WRITE(12,'(A)') '\end{longtable}' WRITE(12,'(A)') '\end{document}' - 405 FORMAT (1X,F14.7,2X,A) - 406 FORMAT (1X,F14.7,A) + 405 FORMAT (1X,F14.7,2X,A) + 406 FORMAT (1X,F14.7,A) 600 FORMAT (1X,2A,1X,F14.7,7A) 700 FORMAT (1X,2A,1X,F14.7,13A) @@ -561,7 +561,7 @@ END SUBROUTINE INDEXS subroutine latexconvert(labelstring,latexstring) ! This subroutine converts a label string to latex -! It is basically the same routine as in renergytable.f90 +! It is basically the same routine as in renergytable.f90 ! Per Jonssson, Malmo University, November 2014 implicit none @@ -589,7 +589,7 @@ subroutine latexconvert(labelstring,latexstring) labelstring(1:i-1) = dummystring(1:i-1) labelstring(i:i) = '\' labelstring(i+1:i+1) = ',' - labelstring(i+2:64) = dummystring(i+1:62) + labelstring(i+2:64) = dummystring(i+1:62) end if end do @@ -606,7 +606,7 @@ subroutine latexconvert(labelstring,latexstring) ncase = 0 do i = 1,61 do j = 48,57 - do k = 48,57 + do k = 48,57 char1 = labelstring(i:i) char2 = labelstring(i+1:i+1) char3 = labelstring(i+2:i+2) @@ -627,10 +627,10 @@ subroutine latexconvert(labelstring,latexstring) end do -! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc +! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc do i = 1,61 -! +! if (labelstring(i:i).eq.'~') then dummystring = labelstring labelstring(1:i) = dummystring(1:i) @@ -642,7 +642,7 @@ subroutine latexconvert(labelstring,latexstring) latexstring = trim(labelstring) return - end subroutine + end subroutine END PROGRAM RTABHFS diff --git a/src/tool/rtablevels.f90 b/src/tool/rtablevels.f90 index 75b8a1c0b..908ffc900 100644 --- a/src/tool/rtablevels.f90 +++ b/src/tool/rtablevels.f90 @@ -3,7 +3,7 @@ program renergytable ! This program makes ASCII and LaTeX tables over energies as a function of ! increasing active sets -! Give the energy lists from rlevels. Start with list corresponding +! Give the energy lists from rlevels. Start with list corresponding ! to the smallest active set and end with the one corresponding to the ! largest. Labels and order of energy levels are according to the last ! energy list. A maximum of 1000 levels in 15 files are allowed. @@ -31,14 +31,14 @@ program renergytable write(*,*) write(*,*) ' RTABLEVELS' -write(*,*) ' Makes LaTeX and ASCII tables of energy files produced by' +write(*,*) ' Makes LaTeX and ASCII tables of energy files produced by' write(*,*) ' rlevels (in ljs format) ' write(*,*) ' Multiple energy files can be used as input' write(*,*) ' Energies from file 1 fills column 1, energies from file 2' write(*,*) ' fills column 2 etc. Checks are done to see if the labels' write(*,*) ' if the labels in the files are consistent' write(*,*) ' Input file: name1, name2, ...' -write(*,*) ' Output files: energylabellatex.tex, energylabelascii.txt' +write(*,*) ' Output files: energylabellatex.tex, energylabelascii.txt' write(*,*) write(*,*) ' Inspect energy files and determine how many positions' write(*,*) ' should be skipped in the string that determines the label ' @@ -75,10 +75,10 @@ program renergytable open(unit=20+i,file=trim(filename),status='old') -! Start reading the file +! Start reading the file k = 0 - do + do read(20+i,'(a)') fileline if (fileline(1:3).eq.'---') then k = k + 1 @@ -100,13 +100,13 @@ program renergytable select case (label(i,nlevels)(lastpos:lastpos)) case ('S','P','D','F','G','H','I','K','L','M','N') - extra(i,nlevels) = ' ' + extra(i,nlevels) = ' ' case default extra(i,nlevels) = label(i,nlevels)(lastpos:lastpos) label(i,nlevels)(lastpos:lastpos) = ' ' end select ! write(*,*) 'Label, jparity',trim(label(i,nlevels)),trim(jparity(i,nlevels)),extra(i,nlevels) - end do + end do ! Check if any levels have the same J, parity and label @@ -122,11 +122,11 @@ program renergytable end do if (nsame.gt.0) then - write(*,*) + write(*,*) write(*,*) write(*,*) 'There are levels with the same labels extra character added' write(*,*) 'at the end to get unique labels' - + i = nfile do j = 1,nlevels nsame = 0 @@ -174,7 +174,7 @@ program renergytable labelstring(1:i-1) = dummystring(1:i-1) labelstring(i:i) = '\' labelstring(i+1:i+1) = ',' - labelstring(i+2:145) = dummystring(i+1:143) + labelstring(i+2:145) = dummystring(i+1:143) end if end do @@ -192,7 +192,7 @@ program renergytable ncase = 0 do i = 1,142 do j = 48,57 - do k = 48,57 + do k = 48,57 char1 = labelstring(i:i) char2 = labelstring(i+1:i+1) char3 = labelstring(i+2:i+2) @@ -211,10 +211,10 @@ program renergytable ! write(*,'(a)') trim(labelstring) end do -! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc +! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc do i = 1,142 -! +! if (labelstring(i:i).eq.'~') then dummystring = labelstring labelstring(1:i) = dummystring(1:i) @@ -223,12 +223,12 @@ program renergytable end if end do - if (jparity(nfile,h)(7:7).eq.'-') then + if (jparity(nfile,h)(7:7).eq.'-') then latexstring(h) = '$'//trim(labelstring)//'_{'//jparity(nfile,h)(1:5)//labelchar(h)//'}^o$' else latexstring(h) = '$'//trim(labelstring)//'_{'//jparity(nfile,h)(1:5)//labelchar(h)//'}$' end if - + ! write(19,'(a)') trim(latexstring(h)) end do @@ -270,8 +270,8 @@ program renergytable end if end do ! write(19,'(a)') latexstring(i)(1:maxlengthlatex)//trim(energystring)//' & '//energy(nfile,i)//' \\' - write(20,'(a)') jparity(nfile,i)//' '//label(nfile,i)(1:maxlengthascii)//extra(nfile,i)//trim(energystring)//' '//energy(nfile,i) -! write(20,'(a)') label(nfile,i)(1:maxlengthascii)//extra(nfile,i)//' '//jparity(nfile,i)//trim(energystring)//' '//energy(nfile,i) + write(20,'(a)') jparity(nfile,i)//' '//label(nfile,i)(1:maxlengthascii)//extra(nfile,i)//trim(energystring)//' '//energy(nfile,i) +! write(20,'(a)') label(nfile,i)(1:maxlengthascii)//extra(nfile,i)//' '//jparity(nfile,i)//trim(energystring)//' '//energy(nfile,i) write(19,'(a)') latexstring(i)(1:maxlengthlatex)//'~'//extra(nfile,i)//trim(energystring)//' & '//energy(nfile,i)//' \\' end do @@ -281,5 +281,3 @@ program renergytable write(19,'(a)') '\end{document}' end program renergytable - - diff --git a/src/tool/rtabtrans1.f90 b/src/tool/rtabtrans1.f90 index 94fc38692..d36b73101 100644 --- a/src/tool/rtabtrans1.f90 +++ b/src/tool/rtabtrans1.f90 @@ -24,16 +24,16 @@ PROGRAM rlevelsname ! * ! Xinghong He 98-10-16 * ! * -! Rewritten by G. Gaigalas * -! for LSJ calssification of levels * +! Rewritten by G. Gaigalas * +! for LSJ calssification of levels * ! NIST May 2011 * -! Adapted by Per Jonsson for producing latex tables November 2014 * +! Adapted by Per Jonsson for producing latex tables November 2014 * ! * !*********************************************************************** IMPLICIT NONE INTEGER, PARAMETER:: JMax = 22 ! max J value, see JFraction ! INTEGER, PARAMETER:: ndim = 20000 ! max number of states - INTEGER, PARAMETER:: maxFile = 1000 ! max number of files + INTEGER, PARAMETER:: maxFile = 1000 ! max number of files DOUBLE PRECISION, PARAMETER:: Rydberg = 109737.31568508D0 ! CHARACTER(LEN=20) strInFile(maxFile), strFile, strFile2 @@ -60,7 +60,7 @@ PROGRAM rlevelsname DOUBLE PRECISION eav, eval(ndim), evec, RLev_ENER(ndim),ZERO ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! DATA PlusMinus/'-', ' ', '+'/ DATA JFraction/' 0 ', ' 1/2', ' 1 ', ' 3/2', ' 2 ', ' 5/2', & @@ -83,7 +83,7 @@ PROGRAM rlevelsname WRITE(*,*) ' functions that are used to compute the ' WRITE(*,*) ' transition data ' WRITE(*,*) ' Output file: energylabel.latex(ascii) ' - WRITE(*,*) + WRITE(*,*) labelchar(:) = ' ' @@ -116,7 +116,7 @@ PROGRAM rlevelsname EXIT ENDIF ENDDO - mFile = i + mFile = i ELSEIF (mFile .GT. 0 .AND. mFile .LE. maxFile) THEN DO i = 1, mFile CALL getarg (i, strInFile(i)) @@ -128,13 +128,13 @@ PROGRAM rlevelsname write(*,*) 'mFile',mFile - write(*,*) + write(*,*) write(*,*) ' Inspect the labels of the states and ' write(*,*) ' determine how many positions should be skipped in ' write(*,*) ' the string that determines the label. For example' write(*,*) ' if all the states have a common core 1s(2) in the ' write(*,*) ' label then 6 positions should be skipped' - write(*,*) + write(*,*) write(*,*) ' How many positions should be skipped?' read(*,*) NSKIP write(*,*) ' Output labels in LaTeX or ASCII format (0/1)? ' @@ -180,7 +180,7 @@ PROGRAM rlevelsname if (strFile2(i:i).eq.'/') then nfound = i exit - end if + end if END DO if (nfound.ne.0) then do i = 1,nfound @@ -194,7 +194,7 @@ PROGRAM rlevelsname then nfound = i exit - end if + end if END DO if (nfound.ne.0) then do i = 1,3 @@ -213,7 +213,7 @@ PROGRAM rlevelsname READ (3) nb, ncfblk, nevblk, iiatjp, iiaspa IF (jblock .NE. nb) THEN ! -! This error can occur anywhere and therefore cannot +! This error can occur anywhere and therefore cannot ! be simply skipped - stop instead. ! WRITE (0,*) 'jblock .NE. nb, stopping...' @@ -252,7 +252,7 @@ PROGRAM rlevelsname OPEN (31, FILE = util_lbl_file, FORM = 'FORMATTED', & STATUS = 'OLD', IOSTAT = IOS) IF (IOS .NE. 0) THEN -!GG WRITE (0,*) 'Failed to open file "', +!GG WRITE (0,*) 'Failed to open file "', !GG & util_lbl_file(1:LEN_TRIM (util_lbl_file)), '", skipping...' CLOSE (31) CYCLE @@ -278,13 +278,13 @@ PROGRAM rlevelsname ! The output of the levels ! WRITE (9,*) - WRITE (9,1) + WRITE (9,1) WRITE (9,2) Rydberg if(Iprint .eq. 1) then WRITE (9,5) WRITE (9,*) 'No - Serial number of the state; ', & 'Pos - Position of the state within the ' - WRITE (9,*) 'J/P block;' + WRITE (9,*) 'J/P block;' WRITE (9,5) WRITE (9,*) 'No Pos J Parity Energy Total Levels', & ' File Configuration' @@ -295,7 +295,7 @@ PROGRAM rlevelsname inputstring = blankstring inputstring(1:64-NSKIP) = string_PRN(i)(1 + NSKIP:64) - if (ascii.eq.1) then + if (ascii.eq.1) then latexstring = inputstring else call latexconvert(inputstring,latexstring) @@ -327,7 +327,7 @@ PROGRAM rlevelsname end if WRITE (9,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), & (eval(i)-eval(indx(1)))*Rydberg*2, & - string_file(i),Trim(latexstring) + string_file(i),Trim(latexstring) END DO ! WRITE (6,5) ELSE @@ -361,11 +361,11 @@ PROGRAM rlevelsname ! character at the end of the label REWIND(9) - NFOUND = 0 + NFOUND = 0 DO READ(9,'(A)') STRING IF (STRING(1:5).EQ.'-----') THEN - NFOUND = NFOUND + 1 + NFOUND = NFOUND + 1 END IF IF (NFOUND.EQ.3) EXIT END DO @@ -391,21 +391,21 @@ PROGRAM rlevelsname labelchar(k) = '~c' else if (nsame.eq.2) then labelchar(k) = '~d' - else + else write(*,*) 'Too many states with the same label' stop end if end if - end do + end do if (nsame.gt.0) labelchar(j) = '~a' end do REWIND(9) - NFOUND = 0 + NFOUND = 0 DO READ(9,'(A)') STRING IF (STRING(1:5).EQ.'-----') THEN - NFOUND = NFOUND + 1 + NFOUND = NFOUND + 1 END IF IF (NFOUND.EQ.3) EXIT END DO @@ -424,7 +424,7 @@ PROGRAM rlevelsname labelchar(j)//finallatex(j)(i:i+3) end if END DO - + CLOSE(9) @@ -529,7 +529,7 @@ SUBROUTINE LDLBL DOUBLE PRECISION RLev_ENER(ndim) ! COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, & - IMaxCount + IMaxCount ! READ (31,'(1A15)',IOSTAT = IOS) RECORD ICount = 0 @@ -563,7 +563,7 @@ SUBROUTINE LDLBL subroutine latexconvert(labelstring,latexstring) ! This subroutine converts a label string to latex -! It is basically the same routine as in renergytable.f90 +! It is basically the same routine as in renergytable.f90 ! Per Jonssson, Malmo University, November 2014 implicit none @@ -591,7 +591,7 @@ subroutine latexconvert(labelstring,latexstring) labelstring(1:i-1) = dummystring(1:i-1) labelstring(i:i) = '\' labelstring(i+1:i+1) = ',' - labelstring(i+2:64) = dummystring(i+1:62) + labelstring(i+2:64) = dummystring(i+1:62) end if end do @@ -608,7 +608,7 @@ subroutine latexconvert(labelstring,latexstring) ncase = 0 do i = 1,61 do j = 48,57 - do k = 48,57 + do k = 48,57 char1 = labelstring(i:i) char2 = labelstring(i+1:i+1) char3 = labelstring(i+2:i+2) @@ -629,10 +629,10 @@ subroutine latexconvert(labelstring,latexstring) end do -! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc +! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc do i = 1,61 -! +! if (labelstring(i:i).eq.'~') then dummystring = labelstring labelstring(1:i) = dummystring(1:i) @@ -644,6 +644,6 @@ subroutine latexconvert(labelstring,latexstring) latexstring = trim(labelstring) return - end subroutine + end subroutine END PROGRAM diff --git a/src/tool/rtabtrans2.f90 b/src/tool/rtabtrans2.f90 index bb165701e..1d05e57b9 100644 --- a/src/tool/rtabtrans2.f90 +++ b/src/tool/rtabtrans2.f90 @@ -1,9 +1,9 @@ !*********************************************************************** ! * - PROGRAM TRANSTABLE + PROGRAM TRANSTABLE ! * ! This program reads the output from biotra2 together with spectral * -! designation and energies to produce a latex table * +! designation and energies to produce a latex table * ! * ! Written by Per Jonsson, Malmo University, November 2010 * ! * @@ -32,31 +32,31 @@ PROGRAM TRANSTABLE REAL*8 DTMEAN,FRAC ! - WRITE(*,*) - WRITE(*,*) ' RTABTRANS2 ' - WRITE(*,*) ' This program reads energy label data and transition' - WRITE(*,*) ' data and creates transition and lifetime tables in ' - WRITE(*,*) ' LaTeX or ASCII format. An Octave file with a ' + WRITE(*,*) + WRITE(*,*) ' RTABTRANS2 ' + WRITE(*,*) ' This program reads energy label data and transition' + WRITE(*,*) ' data and creates transition and lifetime tables in ' + WRITE(*,*) ' LaTeX or ASCII format. An Octave file with a ' WRITE(*,*) ' scatterplot of dT and 10log(A) is also produced ' - WRITE(*,*) + WRITE(*,*) WRITE(*,*) ' Energy label data are given in the file energylabel' WRITE(*,*) ' created by the rtabtrans1 program ' WRITE(*,*) ' Transition data file can be conctenated *.t or *.ct' WRITE(*,*) ' files. ' - WRITE(*,*) + WRITE(*,*) WRITE(*,*) ' Input files: energylabel.latex(ascii), ' WRITE(*,*) ' transitiondatafile ' WRITE(*,*) ' Output files: transitiontable.tex(txt), ' WRITE(*,*) ' lifetimetable.tex(txt), ' - WRITE(*,*) ' scatterplot.m ' - WRITE(*,*) + WRITE(*,*) ' scatterplot.m ' + WRITE(*,*) WRITE(*,*) ' Give the name of the transition data file ' READ(*,*) FILENAME1 WRITE(*,*) ' Energy label file in LaTeX or ASCII format (0/1)? ' READ(*,*) ASCII IF (ASCII.EQ.1) THEN - WRITE(*,*) ' Left column string to denote the ion, e.g. Fe X' + WRITE(*,*) ' Left column string to denote the ion, e.g. Fe X' READ(*,'(A)') LC END IF @@ -95,7 +95,7 @@ PROGRAM TRANSTABLE !---- Read energylabelfile -------------------- NFOUND = 0 - DO + DO READ(37,'(A)') STRING IF (STRING(1:5).EQ.'-----') THEN NFOUND = NFOUND + 1 @@ -108,14 +108,14 @@ PROGRAM TRANSTABLE NLEN = 0 DO READ(37,200,END=91) NO,ILAB(I),JLAB(I),PAR,ENERGY(I), & - DENER,FILE(I),LATEX(I) + DENER,FILE(I),LATEX(I) P(I) = ' ' P(I)(2:2) = PAR - IF (LEN_TRIM(LATEX(I)).GT.NLEN) NLEN = LEN_TRIM(LATEX(I)) + IF (LEN_TRIM(LATEX(I)).GT.NLEN) NLEN = LEN_TRIM(LATEX(I)) JLAB(I) = ADJUSTR(JLAB(I)) I = I + 1 END DO - + 91 CONTINUE N = I - 1 @@ -139,12 +139,12 @@ PROGRAM TRANSTABLE !---- Read transition files --------------------------------------- - K = 1 + K = 1 DO 98 CONTINUE -!---- Start reading the file. Find out if transition between configurations -! or within configuration +!---- Start reading the file. Find out if transition between configurations +! or within configuration READ(36,600) ROW1 IF (LEN(TRIM(ROW1)).GT.22) THEN @@ -156,12 +156,12 @@ PROGRAM TRANSTABLE READ(36,501) FILE1 END IF -!---- Loop over multipolarities in the file +!---- Loop over multipolarities in the file DO 101 CONTINUE - -!---- Find out if electric or magnetic case + +!---- Find out if electric or magnetic case DO I = 1,3 READ(36,'(A)') ROW @@ -178,18 +178,18 @@ PROGRAM TRANSTABLE NEMO = 2 END IF -!---- Continue to read until the rate information comes +!---- Continue to read until the rate information comes DO I = 1,4 READ(36,'(A)') ROW END DO -!---- Start reading the rates for the found polarity (electric or magnetic) +!---- Start reading the rates for the found polarity (electric or magnetic) DO READ(36,300) FU(K),IU(K),JU(K),PU(K),FL(K),IL(K),JL(K), & PL(K),DELTAE(K),GAUGE(K),AV(K),GF(K),S(K) -!---- If magnetic then save rate both in AV(K) and AL(K) +!---- If magnetic then save rate both in AV(K) and AL(K) ! If electric AL(K) will be overwritten as the next line is read AL(K) = AV(K) @@ -200,7 +200,7 @@ PROGRAM TRANSTABLE R(K) = dabs(AL(K)-AV(K))/maxval([AL(K),AV(K)]) END IF IF (FU(K).EQ.'f1') THEN - FILEU(K) = FILE1 + FILEU(K) = FILE1 FILEL(K) = FILE2 ELSE IF (FU(K).EQ.'f2') THEN FILEU(K) = FILE2 @@ -208,9 +208,9 @@ PROGRAM TRANSTABLE ELSE FILEU(K) = FILE1 FILEL(K) = FILE1 - END IF + END IF -!-----Set polarity for case +!-----Set polarity for case IF ((NEM.EQ.1).AND.(NEMO.EQ.1)) THEN EM(K) = 'E1' @@ -222,12 +222,12 @@ PROGRAM TRANSTABLE EM(K) = 'M2' END IF -!---- Try and read another line -! Four cases occur: (1) end of file in which case we close the preset file -! (2) we can read a line and continue reading in the normal way -! (3) we read a blank line which indicates that we have one -! more polarity to read -! (4) we can read a file starting with 'Transition' in which case +!---- Try and read another line +! Four cases occur: (1) end of file in which case we close the preset file +! (2) we can read a line and continue reading in the normal way +! (3) we read a blank line which indicates that we have one +! more polarity to read +! (4) we can read a file starting with 'Transition' in which case ! we have more to read READ(36,700,END=99) ROW @@ -239,19 +239,19 @@ PROGRAM TRANSTABLE END IF BACKSPACE 36 -!---- More polarity +!---- More polarity IF (LEN(TRIM(ROW)).EQ.0) THEN GOTO 101 END IF -!---- More transitions but within new files +!---- More transitions but within new files IF (LEN(TRIM(ROW)).LT.30) THEN GOTO 98 END IF -!---- If not the above cases just continue with another row in the normal way +!---- If not the above cases just continue with another row in the normal way END DO END DO @@ -267,7 +267,7 @@ PROGRAM TRANSTABLE ELSE write(39,'(A)') '\documentclass[10pt]{article}' write(39,'(A)') '\usepackage{longtable}' - write(39,'(A)') '\begin{document}' + write(39,'(A)') '\begin{document}' WRITE(39,'(A)') '\begin{longtable}{lll} \hline' WRITE(39,'(A)') 'State & $\tau_l$ & $\tau_v$ \\ \hline' END IF @@ -297,10 +297,10 @@ PROGRAM TRANSTABLE ' & ',1.D0/TV(J),'\\' END IF END IF - END DO + END DO IF (ASCII.EQ.0) THEN - write(39,'(A)') '\hline\\' + write(39,'(A)') '\hline\\' write(39,'(A)') '\caption{Lifetimes in s.}' write(39,'(A)') '\end{longtable}' write(39,'(A)') '\end{document}' @@ -314,12 +314,12 @@ PROGRAM TRANSTABLE ELSE write(38,'(A)') '\documentclass[10pt]{article}' write(38,'(A)') '\usepackage{longtable}' - write(38,'(A)') '\begin{document}' + write(38,'(A)') '\begin{document}' WRITE(38,'(A)') '\begin{longtable}{lllrllll} \hline' WRITE(38,'(A)') 'Upper & Lower & EM & ', & '$\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) & ', & '$A$ (s$^{-1}$) & $gf$ & $dT$ & - \\ \hline' + \\ \hline' END IF !---- Write header to scatterplot file ------------------------- @@ -338,15 +338,15 @@ PROGRAM TRANSTABLE .AND.(JU(L) == JLAB(J)).AND.(FILEU(L) == FILE(J))) THEN DELTAEEXP = ENERGY(J)-ENERGY(I) DELTAA(L) = 1.0E+8/DELTAE(L) - END IF + END IF END DO END DO - END DO + END DO call HPSORT(K,DELTAA,indx) - DTMEAN = 0.D0 - DTCOUNT = 0.D0 + DTMEAN = 0.D0 + DTCOUNT = 0.D0 IF (NSORT.EQ.0) THEN @@ -363,7 +363,7 @@ PROGRAM TRANSTABLE IF ((AL(L).GT.CUTOFF).OR.(AL(L).GT.FRAC*TL(J))) THEN ! IF (AL(L).GT.CUTOFF) THEN DELTAA(L) = 1.0E+8/DELTAE(L) - IF (EM(L) .EQ. 'M1' .OR. EM(L) .EQ. 'M2') THEN + IF (EM(L) .EQ. 'M1' .OR. EM(L) .EQ. 'M2') THEN IF (ASCII.EQ.1) THEN IF(IDIGITS .EQ. 6) THEN WRITE(38,526)TRIM(LC),' ',JLAB(J),P(J), & @@ -409,7 +409,7 @@ PROGRAM TRANSTABLE IF(IDIGITS .EQ. 6) THEN WRITE(38,426)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN) & ,' & ',EM(L),' & ',INT(DELTAE(L)),' &', & - DELTAA(L),' &',AL(L),' &',GF(L),' &','\\' + DELTAA(L),' &',AL(L),' &',GF(L),' &','\\' ELSEIF (IDIGITS .EQ. 5) THEN WRITE(38,425)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN) & ,' & ',EM(L),' & ',INT(DELTAE(L)),' &', & @@ -427,7 +427,7 @@ PROGRAM TRANSTABLE ,' & ',EM(L),' & ',INT(DELTAE(L)),' &', & DELTAA(L),' &',AL(L),' &',GF(L),' &','\\' ELSEIF (IDIGITS .EQ. 1) THEN - WRITE(38,421)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN) & + WRITE(38,421)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN) & ,' & ',EM(L),' & ',INT(DELTAE(L)),' &', & DELTAA(L),' &',AL(L),' &',GF(L),' &','\\' ELSE @@ -436,7 +436,7 @@ PROGRAM TRANSTABLE END IF END IF ELSE - WRITE(40,*) AL(L), R(L) + WRITE(40,*) AL(L), R(L) DTMEAN = DTMEAN + R(L) DTCOUNT = DTCOUNT + 1.D0 IF (ASCII.EQ.1) THEN @@ -511,11 +511,11 @@ PROGRAM TRANSTABLE END IF END IF END IF - END IF - END IF + END IF + END IF END DO END DO - END DO + END DO ELSE @@ -532,7 +532,7 @@ PROGRAM TRANSTABLE DELTAEEXP = ENERGY(J)-ENERGY(I) IF ((AL(L).GT.CUTOFF).OR.(AL(L).GT.FRAC*TL(J))) THEN DELTAA(L) = 1.0E+8/DELTAE(L) - IF (EM(L) .EQ. 'M1' .OR. EM(L) .EQ. 'M2') THEN + IF (EM(L) .EQ. 'M1' .OR. EM(L) .EQ. 'M2') THEN IF (ASCII.EQ.1) THEN IF(IDIGITS .EQ. 6) THEN WRITE(38,526)TRIM(LC),' ',JLAB(J),P(J), & @@ -603,9 +603,9 @@ PROGRAM TRANSTABLE WRITE(*,*) ' Number of decimals must be 1,...6 ' STOP END IF - END IF + END IF ELSE - WRITE(40,*) AL(L), R(L) + WRITE(40,*) AL(L), R(L) DTMEAN = DTMEAN + R(L) DTCOUNT = DTCOUNT + 1.D0 IF (ASCII.EQ.1) THEN @@ -649,9 +649,9 @@ PROGRAM TRANSTABLE WRITE(*,*) ' Number of decimals must be 1,...6 ' STOP END IF - ELSE + ELSE IF(IDIGITS .EQ. 6) THEN - WRITE(38,416)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN)& + WRITE(38,416)LATEX(J)(1:NLEN),' & ',LATEX(I)(1:NLEN)& ,' & ',EM(L),' & ',INT(DELTAE(L)),' &', & DELTAA(L),' &',AL(L),' &',GF(L),' &',0.1*R(L),'\\' ELSEIF (IDIGITS .EQ. 5) THEN @@ -681,7 +681,7 @@ PROGRAM TRANSTABLE END IF END IF END IF - END IF + END IF END DO END DO END DO @@ -689,10 +689,10 @@ PROGRAM TRANSTABLE END IF WRITE(*,*) - WRITE(*,*) ' Mean dT',DTMEAN/DTCOUNT + WRITE(*,*) ' Mean dT',DTMEAN/DTCOUNT IF (ASCII.EQ.0) THEN - write(38,'(A)') '\hline\\' + write(38,'(A)') '\hline\\' write(38,'(A)') '\caption{Transition data}' write(38,'(A)') '\end{longtable}' write(38,'(A)') '\end{document}' @@ -708,10 +708,10 @@ PROGRAM TRANSTABLE WRITE(*,*) ' Program finished. The transition tables in latex' WRITE(*,*) ' have been written to file ' - 200 FORMAT(2I3,1X,A4,1x,A1,2X,F14.7,F12.2,2X,A14,6X,A) + 200 FORMAT(2I3,1X,A4,1x,A1,2X,F14.7,F12.2,2X,A14,6X,A) !cjb format for highly charged ions in rtransition90/printa.f90 changed !cjb format for highly charged ions in rtransition90/printa.f90 F11.2 -> F13.2 -!cjb format for highly charged ions here 1D12.6 -> 1D14.6 +!cjb format for highly charged ions here 1D12.6 -> 1D14.6 !300 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,1D12.6,A2,1P, & 300 FORMAT(1X,A2,I3,1X,2A4,A2,I3,1X,2A4,1D14.6,A2,1P, & D13.5,2D12.4) @@ -748,7 +748,7 @@ PROGRAM TRANSTABLE 521 FORMAT(12A,I11,A,F20.1,A,1P,E11.3,A,E11.3) CONTAINS - + SUBROUTINE HPSORT(N,RA,IND) double precision RA(N) integer IND(N) @@ -759,7 +759,7 @@ SUBROUTINE HPSORT(N,RA,IND) end do !The index L will be decremented from its initial value during the - !"hiring" (heap creation) phase. Once it reaches 1, the index IR + !"hiring" (heap creation) phase. Once it reaches 1, the index IR !will be decremented from its initial value down to 1 during the !"retirement-and-promotion" (heap selection) phase. 10 continue @@ -792,11 +792,11 @@ SUBROUTINE HPSORT(N,RA,IND) else J=IR+1 end if - + goto 20 end if RA(I)=RRA IND(I)=IRRA goto 10 END SUBROUTINE - END PROGRAM TRANSTABLE + END PROGRAM TRANSTABLE diff --git a/src/tool/rtabtransE1.f90 b/src/tool/rtabtransE1.f90 index 249fb6707..3411e9732 100644 --- a/src/tool/rtabtransE1.f90 +++ b/src/tool/rtabtransE1.f90 @@ -1,445 +1,445 @@ -program rtransitiontable - -! This program makes ASCII and LaTeX tables over transition data - -! Per Jonssson, Malmo University, August 2014 - -implicit none -integer, parameter :: ntrans = 100000 -integer :: h,i,j,k,l, nfile, ntransition, ncase, maxlengthascii1, maxlengthlatex1 -integer :: maxlengthascii2, maxlengthlatex2, nt, nformat, nskip, lastpos -character(len=1) :: char1, char2, char3 -character(len=2) :: j1,j2 -character(len=100) :: filename -character(len=200) :: line1, line2, line3, line4, line5, line6, line7, linedummy -character(len=180) :: labelstring1, labelstring2, dummystring -character(len=180) :: latexstring1(ntrans), latexstring2(ntrans),asciistring1(ntrans),asciistring2(ntrans) -character(len=9) :: sstring(ntrans), gfstring(ntrans), Astring(ntrans) -character(len=1) :: extra1(ntrans), extra2(ntrans) -character(len=8) :: energystring(ntrans) -character(len=13) :: wavelengthstring(ntrans) -character(len=7) :: dTstring(ntrans) - -open(unit=19,file='transitiontable.tex',status='unknown') -open(unit=20,file='transitiontableascii.txt',status='unknown') - -write(*,*) -write(*,*) ' RTABTRANSE1' -write(*,*) ' Makes LaTeX tables of transition data from transition files' -write(*,*) ' name1.name2.ct.lsj ' -write(*,*) ' Input file: name1.name2.ct.lsj' -write(*,*) ' Output file: transitiontable.tex' -write(*,*) - -write(*,*) ' Specify table format ' -write(*,*) ' (1). Lower & Upper & Energy diff. & wavelength & S & gf & A & dT ' -write(*,*) ' (2). Lower & Upper & Energy diff. & wavelength & gf & A & dT ' -write(*,*) ' (3). Lower & Upper & Energy diff. & wavelength & gf & A ' -write(*,*) ' (4). Lower & Upper & Energy diff. & S & gf & A & dT ' -write(*,*) ' (5). Lower & Upper & Energy diff. & gf & A & dT ' -write(*,*) ' (6). Lower & Upper & Energy diff. & gf & A ' -read(*,*) nformat - -write(*,*) ' Inspect the name1.name2.ct.lsj file and determine how many positions' -write(*,*) ' should be skipped in the string that determines the label ' -write(*,*) ' e.g. if the string is 1s(2).2s_2S.2p(2)3P2_4P and 1s(2) is a core' -write(*,*) ' then you would like to skip 1s(2). i.e. 6 positions and determine' -write(*,*) ' the label from 2s_2S.2p(2)3P2_4P' -write(*,*) -write(*,*) ' How many positions should be skipped?' -read(*,*) nskip - -!write(*,*) 'Give the number of files' -!read(*,*) nfile - -write(19,'(a)') '\documentclass[10pt]{article}' -write(19,'(a)') '\usepackage{longtable}' -write(19,'(a)') '\begin{document}' - - -if (nformat.eq.1) then - write(19,'(a)') '\begin{longtable}{llrrrrrr}' - write(19,'(a)') 'Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) &$S$&$gf$& $A$ (s$^{-1}$)&$dT$ \\ \hline' -elseif (nformat.eq.2) then - write(19,'(a)') '\begin{longtable}{llrrrrr}' - write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) & $gf$ & $A$ (s$^{-1}$)&$dT$ \\ \hline' -elseif (nformat.eq.3) then - write(19,'(a)') '\begin{longtable}{llrrrr}' - write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) & $gf$ & $A$ (s$^{-1}$) \\ \hline' -elseif (nformat.eq.4) then - write(19,'(a)') '\begin{longtable}{llrrrrr}' - write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $S$ & $gf$ & $A$ (s$^{-1}$) & $dT$ \\ \hline' -elseif (nformat.eq.5) then - write(19,'(a)') '\begin{longtable}{llrrrr}' - write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $gf$ & $A$ (s$^{-1}$) & $dT$ \\ \hline' -elseif (nformat.eq.6) then - write(19,'(a)') '\begin{longtable}{llrrr}' - write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $gf$ & $A$ (s$^{-1}$) \\ \hline' -end if - -nfile = 1 -do h = 1,nfile - - - - write(*,'(a)') ' Name of file' - read(*,'(a)') filename - - open(unit=20+h,file=trim(filename),status='old') - -! Start reading the file - - do j = 1,3 - read(20+h,'(a)') linedummy - end do - - - nt = 0 - maxlengthascii1 = 0 - maxlengthlatex1 = 0 - maxlengthascii2 = 0 - maxlengthlatex2 = 0 - do - read(20+h,'(a)',end=999) linedummy - read(20+h,'(a)') linedummy - read(20+h,'(a)') line1 - read(20+h,'(a)') line2 - read(20+h,'(a)') line3 - read(20+h,'(a)') line4 - read(20+h,'(a)') line5 - nt = nt + 1 - if (nt.eq.ntrans) then - write(*,*) 'Too many transitions' - write(*,*) 'Increase ntrans and recompile' - stop - end if - - labelstring1 = line1(21+nskip:200) - labelstring2 = line2(21+nskip:200) - - lastpos = len_trim(labelstring1) - - select case (labelstring1(lastpos:lastpos)) - case ('S','P','D','F','G','H','I','K','L','M','N') - extra1(nt) = ' ' - case default - extra1(nt) = labelstring1(lastpos:lastpos) - labelstring1(lastpos:lastpos) = ' ' - end select - - lastpos = len_trim(labelstring2) - - select case (labelstring2(lastpos:lastpos)) - case ('S','P','D','F','G','H','I','K','L','M','N') - extra2(nt) = ' ' - case default - extra2(nt) = labelstring2(lastpos:lastpos) - labelstring2(lastpos:lastpos) = ' ' - end select - - - - - - - - asciistring1(nt) = line1(21+nskip:200) - asciistring2(nt) = line2(21+nskip:200) - j1 = line1(3:4) - j2 = line2(3:4) - -! energystring(nt) = line3(1:11) -! wavelengthstring(nt) = line3(17:29) -! sstring(nt) = line4(11:21) -! gfstring(nt) = line4(31:41) -! Astring(nt) = line4(52:62) -! dTstring(nt) = line4(70:78) - - energystring(nt) = line3(1:8) - wavelengthstring(nt) = line3(17:29) - sstring(nt) = line4(11:15)//line4(18:21) - gfstring(nt) = line4(31:35)//line4(38:41) - Astring(nt) = line4(52:56)//line4(59:62) - dTstring(nt) = line4(70:76) -! write(*,*) labelstring1 -! write(*,*) labelstring2 - - -! Convert quantum labels -! to LaTeX - - - do i = 1,177 - -! Replace (n) with ^n - - if ((labelstring1(i:i).eq.'(').and.(labelstring1(i+2:i+2).eq.')')) then - labelstring1(i:i) = '^' - labelstring1(i+2:i+2) = ' ' - end if - if ((labelstring2(i:i).eq.'(').and.(labelstring2(i+2:i+2).eq.')')) then - labelstring2(i:i) = '^' - labelstring2(i+2:i+2) = ' ' - end if - end do - - do i = 1,177 - -! Replace . with \, - - if (labelstring1(i:i).eq.'.') then - dummystring = labelstring1 - labelstring1(1:i-1) = dummystring(1:i-1) - labelstring1(i:i) = '\' - labelstring1(i+1:i+1) = ',' - labelstring1(i+2:145) = dummystring(i+1:143) - end if - if (labelstring2(i:i).eq.'.') then - dummystring = labelstring2 - labelstring2(1:i-1) = dummystring(1:i-1) - labelstring2(i:i) = '\' - labelstring2(i+1:i+1) = ',' - labelstring2(i+2:145) = dummystring(i+1:143) - end if - end do - - do i = 1,177 - -! Replace _ with ~ - - if (labelstring1(i:i).eq.'_') labelstring1(i:i) = '~' - if (labelstring2(i:i).eq.'_') labelstring2(i:i) = '~' - end do -! write(*,'(a)') trim(labelstring1) -! write(*,'(a)') trim(labelstring2) - -! If integer1 and S, P, D, F, G, H, I, K, L, M, N and integer2 replace with (^integer1_integer2S), (^integer1_integer2P), etc - - do l = 1,15 - ncase = 0 - do i = 1,177 - do j = 48,57 - do k = 48,57 - char1 = labelstring1(i:i) - char2 = labelstring1(i+1:i+1) - char3 = labelstring1(i+2:i+2) - if ((ichar(char1).eq.j).and.(ichar(char3).eq.k).and.((char2.ne.'~').and.(char2.ne.' ').and.(char2.ne.'_'))) then - dummystring = labelstring1 - labelstring1(1:i-1) = dummystring(1:i-1) - labelstring1(i:i+6) = '(^'//char1//'_'//char3//char2//')' - labelstring1(i+7:145) = dummystring(i+3:141) - ncase = ncase + 1 - end if - end do - end do - if (ncase.eq.1) exit - end do - -! write(*,'(a)') trim(labelstring1) - end do - - do l = 1,15 - ncase = 0 - do i = 1,177 - do j = 48,57 - do k = 48,57 - char1 = labelstring2(i:i) - char2 = labelstring2(i+1:i+1) - char3 = labelstring2(i+2:i+2) - if ((ichar(char1).eq.j).and.(ichar(char3).eq.k).and.((char2.ne.'~').and.(char2.ne.' ').and.(char2.ne.'_'))) then - dummystring = labelstring2 - labelstring2(1:i-1) = dummystring(1:i-1) - labelstring2(i:i+6) = '(^'//char1//'_'//char3//char2//')' - labelstring2(i+7:145) = dummystring(i+3:141) - ncase = ncase + 1 - end if - end do - end do - if (ncase.eq.1) exit - end do - -! write(*,'(a)') trim(labelstring2) - end do - -! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc - - do i = 1,177 -! - if (labelstring1(i:i).eq.'~') then - dummystring = labelstring1 - labelstring1(1:i) = dummystring(1:i) - labelstring1(i+1:i+1) = '^' - labelstring1(i+2:145) = dummystring(i+1:143) - end if - if (labelstring2(i:i).eq.'~') then - dummystring = labelstring2 - labelstring2(1:i) = dummystring(1:i) - labelstring2(i+1:i+1) = '^' - labelstring2(i+2:145) = dummystring(i+1:143) - end if - end do - - if (j1.eq.' 0') labelstring1 = '$'//trim(labelstring1)//'_{0}$' - if (j2.eq.' 0') labelstring2 = '$'//trim(labelstring2)//'_{0}$' - if (j1.eq.' 1') labelstring1 = '$'//trim(labelstring1)//'_{1/2}$' - if (j2.eq.' 1') labelstring2 = '$'//trim(labelstring2)//'_{1/2}$' - if (j1.eq.' 2') labelstring1 = '$'//trim(labelstring1)//'_{1}$' - if (j2.eq.' 2') labelstring2 = '$'//trim(labelstring2)//'_{1}$' - if (j1.eq.' 3') labelstring1 = '$'//trim(labelstring1)//'_{3/2}$' - if (j2.eq.' 3') labelstring2 = '$'//trim(labelstring2)//'_{3/2}$' - if (j1.eq.' 4') labelstring1 = '$'//trim(labelstring1)//'_{2}$' - if (j2.eq.' 4') labelstring2 = '$'//trim(labelstring2)//'_{2}$' - if (j1.eq.' 5') labelstring1 = '$'//trim(labelstring1)//'_{5/2}$' - if (j2.eq.' 5') labelstring2 = '$'//trim(labelstring2)//'_{5/2}$' - if (j1.eq.' 6') labelstring1 = '$'//trim(labelstring1)//'_{3}$' - if (j2.eq.' 6') labelstring2 = '$'//trim(labelstring2)//'_{3}$' - if (j1.eq.' 7') labelstring1 = '$'//trim(labelstring1)//'_{7/2}$' - if (j2.eq.' 7') labelstring2 = '$'//trim(labelstring2)//'_{7/2}$' - if (j1.eq.' 8') labelstring1 = '$'//trim(labelstring1)//'_{4}$' - if (j2.eq.' 8') labelstring2 = '$'//trim(labelstring2)//'_{4}$' - if (j1.eq.' 9') labelstring1 = '$'//trim(labelstring1)//'_{9/2}$' - if (j2.eq.' 9') labelstring2 = '$'//trim(labelstring2)//'_{9/2}$' - if (j1.eq.'10') labelstring1 = '$'//trim(labelstring1)//'_{5}$' - if (j2.eq.'10') labelstring2 = '$'//trim(labelstring2)//'_{5}$' - if (j1.eq.'11') labelstring1 = '$'//trim(labelstring1)//'_{11/2}$' - if (j2.eq.'11') labelstring2 = '$'//trim(labelstring2)//'_{11/2}$' - if (j1.eq.'12') labelstring1 = '$'//trim(labelstring1)//'_{6}$' - if (j2.eq.'12') labelstring2 = '$'//trim(labelstring2)//'_{6}$' - if (j1.eq.'13') labelstring1 = '$'//trim(labelstring1)//'_{13/2}$' - if (j2.eq.'13') labelstring2 = '$'//trim(labelstring2)//'_{13/2}$' - if (j1.eq.'14') labelstring1 = '$'//trim(labelstring1)//'_{7}$' - if (j2.eq.'14') labelstring2 = '$'//trim(labelstring2)//'_{7}$' - if (j1.eq.'15') labelstring1 = '$'//trim(labelstring1)//'_{15/2}$' - if (j2.eq.'15') labelstring2 = '$'//trim(labelstring2)//'_{15/2}$' - if (j1.eq.'16') labelstring1 = '$'//trim(labelstring1)//'_{8}$' - if (j2.eq.'16') labelstring2 = '$'//trim(labelstring2)//'_{8}$' - if (j1.eq.'17') labelstring1 = '$'//trim(labelstring1)//'_{17/2}$' - if (j2.eq.'17') labelstring2 = '$'//trim(labelstring2)//'_{17/2}$' - if (j1.eq.'18') labelstring1 = '$'//trim(labelstring1)//'_{9}$' - if (j2.eq.'18') labelstring2 = '$'//trim(labelstring2)//'_{9}$' - if (j1.eq.'19') labelstring1 = '$'//trim(labelstring1)//'_{19/2}$' - if (j2.eq.'19') labelstring2 = '$'//trim(labelstring2)//'_{19/2}$' - - if (len_trim(labelstring1).gt.maxlengthlatex1) maxlengthlatex1 = len_trim(labelstring1) - if (len_trim(labelstring2).gt.maxlengthlatex2) maxlengthlatex2 = len_trim(labelstring2) - - latexstring1(nt) = labelstring1 - latexstring2(nt) = labelstring2 - - if (j1.eq.' 0') asciistring1(nt) = trim(asciistring1(nt))//' 0 ' - if (j2.eq.' 0') asciistring2(nt) = trim(asciistring2(nt))//' 0 ' - if (j1.eq.' 1') asciistring1(nt) = trim(asciistring1(nt))//' 1/2' - if (j2.eq.' 1') asciistring2(nt) = trim(asciistring2(nt))//' 1/2' - if (j1.eq.' 2') asciistring1(nt) = trim(asciistring1(nt))//' 1 ' - if (j2.eq.' 2') asciistring2(nt) = trim(asciistring2(nt))//' 1 ' - if (j1.eq.' 3') asciistring1(nt) = trim(asciistring1(nt))//' 3/2' - if (j2.eq.' 3') asciistring2(nt) = trim(asciistring2(nt))//' 3/2' - if (j1.eq.' 4') asciistring1(nt) = trim(asciistring1(nt))//' 2 ' - if (j2.eq.' 4') asciistring2(nt) = trim(asciistring2(nt))//' 2 ' - if (j1.eq.' 5') asciistring1(nt) = trim(asciistring1(nt))//' 5/2' - if (j2.eq.' 5') asciistring2(nt) = trim(asciistring2(nt))//' 5/2' - if (j1.eq.' 6') asciistring1(nt) = trim(asciistring1(nt))//' 3 ' - if (j2.eq.' 6') asciistring2(nt) = trim(asciistring2(nt))//' 3 ' - if (j1.eq.' 7') asciistring1(nt) = trim(asciistring1(nt))//' 7/2' - if (j2.eq.' 7') asciistring2(nt) = trim(asciistring2(nt))//' 7/2' - if (j1.eq.' 8') asciistring1(nt) = trim(asciistring1(nt))//' 4 ' - if (j2.eq.' 8') asciistring2(nt) = trim(asciistring2(nt))//' 4 ' - if (j1.eq.' 9') asciistring1(nt) = trim(asciistring1(nt))//' 9/2' - if (j2.eq.' 9') asciistring2(nt) = trim(asciistring2(nt))//' 9/2' - if (j1.eq.'10') asciistring1(nt) = trim(asciistring1(nt))//' 5 ' - if (j2.eq.'10') asciistring2(nt) = trim(asciistring2(nt))//' 5 ' - if (j1.eq.'11') asciistring1(nt) = trim(asciistring1(nt))//' 11/2' - if (j2.eq.'11') asciistring2(nt) = trim(asciistring2(nt))//' 11/2' - if (j1.eq.'12') asciistring1(nt) = trim(asciistring1(nt))//' 6 ' - if (j2.eq.'12') asciistring2(nt) = trim(asciistring2(nt))//' 6 ' - if (j1.eq.'13') asciistring1(nt) = trim(asciistring1(nt))//' 13/2' - if (j2.eq.'13') asciistring2(nt) = trim(asciistring2(nt))//' 13/2' - if (j1.eq.'14') asciistring1(nt) = trim(asciistring1(nt))//' 7 ' - if (j2.eq.'14') asciistring2(nt) = trim(asciistring2(nt))//' 7 ' - if (j1.eq.'15') asciistring1(nt) = trim(asciistring1(nt))//' 15/2' - if (j2.eq.'15') asciistring2(nt) = trim(asciistring2(nt))//' 15/2' - if (j1.eq.'16') asciistring1(nt) = trim(asciistring1(nt))//' 8 ' - if (j2.eq.'16') asciistring2(nt) = trim(asciistring2(nt))//' 8 ' - if (j1.eq.'17') asciistring1(nt) = trim(asciistring1(nt))//' 17/2' - if (j2.eq.'17') asciistring2(nt) = trim(asciistring2(nt))//' 17/2' - if (j1.eq.'18') asciistring1(nt) = trim(asciistring1(nt))//' 9 ' - if (j2.eq.'18') asciistring2(nt) = trim(asciistring2(nt))//' 9 ' - if (j1.eq.'19') asciistring1(nt) = trim(asciistring1(nt))//' 19/2' - if (j2.eq.'19') asciistring2(nt) = trim(asciistring2(nt))//' 19/2' - - if (len_trim(asciistring1(nt)).gt.maxlengthascii1) maxlengthascii1 = len_trim(asciistring1(nt)) - if (len_trim(asciistring2(nt)).gt.maxlengthascii2) maxlengthascii2 = len_trim(asciistring2(nt)) - - end do -999 continue - - do i = 1,nt - if (nformat.eq.1) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//wavelengthstring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.2) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//wavelengthstring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.3) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//wavelengthstring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//'\\' - elseif (nformat.eq.4) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.5) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.6) then - write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& - & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& - &energystring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//'\\' - end if - if (nformat.eq.1) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& - &energystring(i)//' '//wavelengthstring(i)//' '//sstring(i)//' '//gfstring(i)//' '//& - &Astring(i)//' '//dTstring(i) - elseif (nformat.eq.2) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& - &energystring(i)//' '//wavelengthstring(i)//' '//gfstring(i)//' '//& - &Astring(i)//' '//dTstring(i) - elseif (nformat.eq.3) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& - &energystring(i)//' '//wavelengthstring(i)//' '//gfstring(i)//' '//& - &Astring(i) - elseif (nformat.eq.4) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& - &energystring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.5) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& - &energystring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//' & '//dTstring(i)//'\\' - elseif (nformat.eq.6) then - write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& - &energystring(i)//' & '//gfstring(i)//' & '//& - &Astring(i)//'\\' - end if - end do - -write(19,'(a)') '\hline\\' -write(19,'(a)') '\caption{Transition data from the file '//trim(filename)//'}' -write(19,'(a)') '\end{longtable}' -write(19,'(a)') '\end{document}' - -end do - -end program rtransitiontable - - - +program rtransitiontable + +! This program makes ASCII and LaTeX tables over transition data + +! Per Jonssson, Malmo University, August 2014 + +implicit none +integer, parameter :: ntrans = 100000 +integer :: h,i,j,k,l, nfile, ntransition, ncase, maxlengthascii1, maxlengthlatex1 +integer :: maxlengthascii2, maxlengthlatex2, nt, nformat, nskip, lastpos +character(len=1) :: char1, char2, char3 +character(len=2) :: j1,j2 +character(len=100) :: filename +character(len=200) :: line1, line2, line3, line4, line5, line6, line7, linedummy +character(len=180) :: labelstring1, labelstring2, dummystring +character(len=180) :: latexstring1(ntrans), latexstring2(ntrans),asciistring1(ntrans),asciistring2(ntrans) +character(len=9) :: sstring(ntrans), gfstring(ntrans), Astring(ntrans) +character(len=1) :: extra1(ntrans), extra2(ntrans) +character(len=8) :: energystring(ntrans) +character(len=13) :: wavelengthstring(ntrans) +character(len=7) :: dTstring(ntrans) + +open(unit=19,file='transitiontable.tex',status='unknown') +open(unit=20,file='transitiontableascii.txt',status='unknown') + +write(*,*) +write(*,*) ' RTABTRANSE1' +write(*,*) ' Makes LaTeX tables of transition data from transition files' +write(*,*) ' name1.name2.ct.lsj ' +write(*,*) ' Input file: name1.name2.ct.lsj' +write(*,*) ' Output file: transitiontable.tex' +write(*,*) + +write(*,*) ' Specify table format ' +write(*,*) ' (1). Lower & Upper & Energy diff. & wavelength & S & gf & A & dT ' +write(*,*) ' (2). Lower & Upper & Energy diff. & wavelength & gf & A & dT ' +write(*,*) ' (3). Lower & Upper & Energy diff. & wavelength & gf & A ' +write(*,*) ' (4). Lower & Upper & Energy diff. & S & gf & A & dT ' +write(*,*) ' (5). Lower & Upper & Energy diff. & gf & A & dT ' +write(*,*) ' (6). Lower & Upper & Energy diff. & gf & A ' +read(*,*) nformat + +write(*,*) ' Inspect the name1.name2.ct.lsj file and determine how many positions' +write(*,*) ' should be skipped in the string that determines the label ' +write(*,*) ' e.g. if the string is 1s(2).2s_2S.2p(2)3P2_4P and 1s(2) is a core' +write(*,*) ' then you would like to skip 1s(2). i.e. 6 positions and determine' +write(*,*) ' the label from 2s_2S.2p(2)3P2_4P' +write(*,*) +write(*,*) ' How many positions should be skipped?' +read(*,*) nskip + +!write(*,*) 'Give the number of files' +!read(*,*) nfile + +write(19,'(a)') '\documentclass[10pt]{article}' +write(19,'(a)') '\usepackage{longtable}' +write(19,'(a)') '\begin{document}' + + +if (nformat.eq.1) then + write(19,'(a)') '\begin{longtable}{llrrrrrr}' + write(19,'(a)') 'Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) &$S$&$gf$& $A$ (s$^{-1}$)&$dT$ \\ \hline' +elseif (nformat.eq.2) then + write(19,'(a)') '\begin{longtable}{llrrrrr}' + write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) & $gf$ & $A$ (s$^{-1}$)&$dT$ \\ \hline' +elseif (nformat.eq.3) then + write(19,'(a)') '\begin{longtable}{llrrrr}' + write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $\lambda$ (\AA) & $gf$ & $A$ (s$^{-1}$) \\ \hline' +elseif (nformat.eq.4) then + write(19,'(a)') '\begin{longtable}{llrrrrr}' + write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $S$ & $gf$ & $A$ (s$^{-1}$) & $dT$ \\ \hline' +elseif (nformat.eq.5) then + write(19,'(a)') '\begin{longtable}{llrrrr}' + write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $gf$ & $A$ (s$^{-1}$) & $dT$ \\ \hline' +elseif (nformat.eq.6) then + write(19,'(a)') '\begin{longtable}{llrrr}' + write(19,'(a)') ' Lower state & Upper state & $\Delta E$ (cm$^{-1}$) & $gf$ & $A$ (s$^{-1}$) \\ \hline' +end if + +nfile = 1 +do h = 1,nfile + + + + write(*,'(a)') ' Name of file' + read(*,'(a)') filename + + open(unit=20+h,file=trim(filename),status='old') + +! Start reading the file + + do j = 1,3 + read(20+h,'(a)') linedummy + end do + + + nt = 0 + maxlengthascii1 = 0 + maxlengthlatex1 = 0 + maxlengthascii2 = 0 + maxlengthlatex2 = 0 + do + read(20+h,'(a)',end=999) linedummy + read(20+h,'(a)') linedummy + read(20+h,'(a)') line1 + read(20+h,'(a)') line2 + read(20+h,'(a)') line3 + read(20+h,'(a)') line4 + read(20+h,'(a)') line5 + nt = nt + 1 + if (nt.eq.ntrans) then + write(*,*) 'Too many transitions' + write(*,*) 'Increase ntrans and recompile' + stop + end if + + labelstring1 = line1(21+nskip:200) + labelstring2 = line2(21+nskip:200) + + lastpos = len_trim(labelstring1) + + select case (labelstring1(lastpos:lastpos)) + case ('S','P','D','F','G','H','I','K','L','M','N') + extra1(nt) = ' ' + case default + extra1(nt) = labelstring1(lastpos:lastpos) + labelstring1(lastpos:lastpos) = ' ' + end select + + lastpos = len_trim(labelstring2) + + select case (labelstring2(lastpos:lastpos)) + case ('S','P','D','F','G','H','I','K','L','M','N') + extra2(nt) = ' ' + case default + extra2(nt) = labelstring2(lastpos:lastpos) + labelstring2(lastpos:lastpos) = ' ' + end select + + + + + + + + asciistring1(nt) = line1(21+nskip:200) + asciistring2(nt) = line2(21+nskip:200) + j1 = line1(3:4) + j2 = line2(3:4) + +! energystring(nt) = line3(1:11) +! wavelengthstring(nt) = line3(17:29) +! sstring(nt) = line4(11:21) +! gfstring(nt) = line4(31:41) +! Astring(nt) = line4(52:62) +! dTstring(nt) = line4(70:78) + + energystring(nt) = line3(1:8) + wavelengthstring(nt) = line3(17:29) + sstring(nt) = line4(11:15)//line4(18:21) + gfstring(nt) = line4(31:35)//line4(38:41) + Astring(nt) = line4(52:56)//line4(59:62) + dTstring(nt) = line4(70:76) +! write(*,*) labelstring1 +! write(*,*) labelstring2 + + +! Convert quantum labels +! to LaTeX + + + do i = 1,177 + +! Replace (n) with ^n + + if ((labelstring1(i:i).eq.'(').and.(labelstring1(i+2:i+2).eq.')')) then + labelstring1(i:i) = '^' + labelstring1(i+2:i+2) = ' ' + end if + if ((labelstring2(i:i).eq.'(').and.(labelstring2(i+2:i+2).eq.')')) then + labelstring2(i:i) = '^' + labelstring2(i+2:i+2) = ' ' + end if + end do + + do i = 1,177 + +! Replace . with \, + + if (labelstring1(i:i).eq.'.') then + dummystring = labelstring1 + labelstring1(1:i-1) = dummystring(1:i-1) + labelstring1(i:i) = '\' + labelstring1(i+1:i+1) = ',' + labelstring1(i+2:145) = dummystring(i+1:143) + end if + if (labelstring2(i:i).eq.'.') then + dummystring = labelstring2 + labelstring2(1:i-1) = dummystring(1:i-1) + labelstring2(i:i) = '\' + labelstring2(i+1:i+1) = ',' + labelstring2(i+2:145) = dummystring(i+1:143) + end if + end do + + do i = 1,177 + +! Replace _ with ~ + + if (labelstring1(i:i).eq.'_') labelstring1(i:i) = '~' + if (labelstring2(i:i).eq.'_') labelstring2(i:i) = '~' + end do +! write(*,'(a)') trim(labelstring1) +! write(*,'(a)') trim(labelstring2) + +! If integer1 and S, P, D, F, G, H, I, K, L, M, N and integer2 replace with (^integer1_integer2S), (^integer1_integer2P), etc + + do l = 1,15 + ncase = 0 + do i = 1,177 + do j = 48,57 + do k = 48,57 + char1 = labelstring1(i:i) + char2 = labelstring1(i+1:i+1) + char3 = labelstring1(i+2:i+2) + if ((ichar(char1).eq.j).and.(ichar(char3).eq.k).and.((char2.ne.'~').and.(char2.ne.' ').and.(char2.ne.'_'))) then + dummystring = labelstring1 + labelstring1(1:i-1) = dummystring(1:i-1) + labelstring1(i:i+6) = '(^'//char1//'_'//char3//char2//')' + labelstring1(i+7:145) = dummystring(i+3:141) + ncase = ncase + 1 + end if + end do + end do + if (ncase.eq.1) exit + end do + +! write(*,'(a)') trim(labelstring1) + end do + + do l = 1,15 + ncase = 0 + do i = 1,177 + do j = 48,57 + do k = 48,57 + char1 = labelstring2(i:i) + char2 = labelstring2(i+1:i+1) + char3 = labelstring2(i+2:i+2) + if ((ichar(char1).eq.j).and.(ichar(char3).eq.k).and.((char2.ne.'~').and.(char2.ne.' ').and.(char2.ne.'_'))) then + dummystring = labelstring2 + labelstring2(1:i-1) = dummystring(1:i-1) + labelstring2(i:i+6) = '(^'//char1//'_'//char3//char2//')' + labelstring2(i+7:145) = dummystring(i+3:141) + ncase = ncase + 1 + end if + end do + end do + if (ncase.eq.1) exit + end do + +! write(*,'(a)') trim(labelstring2) + end do + +! If integer1 and S, P, D, F, G, H, I, K, L, M, N and not integer2 replace with ^integer1S, ^integer1P, etc + + do i = 1,177 +! + if (labelstring1(i:i).eq.'~') then + dummystring = labelstring1 + labelstring1(1:i) = dummystring(1:i) + labelstring1(i+1:i+1) = '^' + labelstring1(i+2:145) = dummystring(i+1:143) + end if + if (labelstring2(i:i).eq.'~') then + dummystring = labelstring2 + labelstring2(1:i) = dummystring(1:i) + labelstring2(i+1:i+1) = '^' + labelstring2(i+2:145) = dummystring(i+1:143) + end if + end do + + if (j1.eq.' 0') labelstring1 = '$'//trim(labelstring1)//'_{0}$' + if (j2.eq.' 0') labelstring2 = '$'//trim(labelstring2)//'_{0}$' + if (j1.eq.' 1') labelstring1 = '$'//trim(labelstring1)//'_{1/2}$' + if (j2.eq.' 1') labelstring2 = '$'//trim(labelstring2)//'_{1/2}$' + if (j1.eq.' 2') labelstring1 = '$'//trim(labelstring1)//'_{1}$' + if (j2.eq.' 2') labelstring2 = '$'//trim(labelstring2)//'_{1}$' + if (j1.eq.' 3') labelstring1 = '$'//trim(labelstring1)//'_{3/2}$' + if (j2.eq.' 3') labelstring2 = '$'//trim(labelstring2)//'_{3/2}$' + if (j1.eq.' 4') labelstring1 = '$'//trim(labelstring1)//'_{2}$' + if (j2.eq.' 4') labelstring2 = '$'//trim(labelstring2)//'_{2}$' + if (j1.eq.' 5') labelstring1 = '$'//trim(labelstring1)//'_{5/2}$' + if (j2.eq.' 5') labelstring2 = '$'//trim(labelstring2)//'_{5/2}$' + if (j1.eq.' 6') labelstring1 = '$'//trim(labelstring1)//'_{3}$' + if (j2.eq.' 6') labelstring2 = '$'//trim(labelstring2)//'_{3}$' + if (j1.eq.' 7') labelstring1 = '$'//trim(labelstring1)//'_{7/2}$' + if (j2.eq.' 7') labelstring2 = '$'//trim(labelstring2)//'_{7/2}$' + if (j1.eq.' 8') labelstring1 = '$'//trim(labelstring1)//'_{4}$' + if (j2.eq.' 8') labelstring2 = '$'//trim(labelstring2)//'_{4}$' + if (j1.eq.' 9') labelstring1 = '$'//trim(labelstring1)//'_{9/2}$' + if (j2.eq.' 9') labelstring2 = '$'//trim(labelstring2)//'_{9/2}$' + if (j1.eq.'10') labelstring1 = '$'//trim(labelstring1)//'_{5}$' + if (j2.eq.'10') labelstring2 = '$'//trim(labelstring2)//'_{5}$' + if (j1.eq.'11') labelstring1 = '$'//trim(labelstring1)//'_{11/2}$' + if (j2.eq.'11') labelstring2 = '$'//trim(labelstring2)//'_{11/2}$' + if (j1.eq.'12') labelstring1 = '$'//trim(labelstring1)//'_{6}$' + if (j2.eq.'12') labelstring2 = '$'//trim(labelstring2)//'_{6}$' + if (j1.eq.'13') labelstring1 = '$'//trim(labelstring1)//'_{13/2}$' + if (j2.eq.'13') labelstring2 = '$'//trim(labelstring2)//'_{13/2}$' + if (j1.eq.'14') labelstring1 = '$'//trim(labelstring1)//'_{7}$' + if (j2.eq.'14') labelstring2 = '$'//trim(labelstring2)//'_{7}$' + if (j1.eq.'15') labelstring1 = '$'//trim(labelstring1)//'_{15/2}$' + if (j2.eq.'15') labelstring2 = '$'//trim(labelstring2)//'_{15/2}$' + if (j1.eq.'16') labelstring1 = '$'//trim(labelstring1)//'_{8}$' + if (j2.eq.'16') labelstring2 = '$'//trim(labelstring2)//'_{8}$' + if (j1.eq.'17') labelstring1 = '$'//trim(labelstring1)//'_{17/2}$' + if (j2.eq.'17') labelstring2 = '$'//trim(labelstring2)//'_{17/2}$' + if (j1.eq.'18') labelstring1 = '$'//trim(labelstring1)//'_{9}$' + if (j2.eq.'18') labelstring2 = '$'//trim(labelstring2)//'_{9}$' + if (j1.eq.'19') labelstring1 = '$'//trim(labelstring1)//'_{19/2}$' + if (j2.eq.'19') labelstring2 = '$'//trim(labelstring2)//'_{19/2}$' + + if (len_trim(labelstring1).gt.maxlengthlatex1) maxlengthlatex1 = len_trim(labelstring1) + if (len_trim(labelstring2).gt.maxlengthlatex2) maxlengthlatex2 = len_trim(labelstring2) + + latexstring1(nt) = labelstring1 + latexstring2(nt) = labelstring2 + + if (j1.eq.' 0') asciistring1(nt) = trim(asciistring1(nt))//' 0 ' + if (j2.eq.' 0') asciistring2(nt) = trim(asciistring2(nt))//' 0 ' + if (j1.eq.' 1') asciistring1(nt) = trim(asciistring1(nt))//' 1/2' + if (j2.eq.' 1') asciistring2(nt) = trim(asciistring2(nt))//' 1/2' + if (j1.eq.' 2') asciistring1(nt) = trim(asciistring1(nt))//' 1 ' + if (j2.eq.' 2') asciistring2(nt) = trim(asciistring2(nt))//' 1 ' + if (j1.eq.' 3') asciistring1(nt) = trim(asciistring1(nt))//' 3/2' + if (j2.eq.' 3') asciistring2(nt) = trim(asciistring2(nt))//' 3/2' + if (j1.eq.' 4') asciistring1(nt) = trim(asciistring1(nt))//' 2 ' + if (j2.eq.' 4') asciistring2(nt) = trim(asciistring2(nt))//' 2 ' + if (j1.eq.' 5') asciistring1(nt) = trim(asciistring1(nt))//' 5/2' + if (j2.eq.' 5') asciistring2(nt) = trim(asciistring2(nt))//' 5/2' + if (j1.eq.' 6') asciistring1(nt) = trim(asciistring1(nt))//' 3 ' + if (j2.eq.' 6') asciistring2(nt) = trim(asciistring2(nt))//' 3 ' + if (j1.eq.' 7') asciistring1(nt) = trim(asciistring1(nt))//' 7/2' + if (j2.eq.' 7') asciistring2(nt) = trim(asciistring2(nt))//' 7/2' + if (j1.eq.' 8') asciistring1(nt) = trim(asciistring1(nt))//' 4 ' + if (j2.eq.' 8') asciistring2(nt) = trim(asciistring2(nt))//' 4 ' + if (j1.eq.' 9') asciistring1(nt) = trim(asciistring1(nt))//' 9/2' + if (j2.eq.' 9') asciistring2(nt) = trim(asciistring2(nt))//' 9/2' + if (j1.eq.'10') asciistring1(nt) = trim(asciistring1(nt))//' 5 ' + if (j2.eq.'10') asciistring2(nt) = trim(asciistring2(nt))//' 5 ' + if (j1.eq.'11') asciistring1(nt) = trim(asciistring1(nt))//' 11/2' + if (j2.eq.'11') asciistring2(nt) = trim(asciistring2(nt))//' 11/2' + if (j1.eq.'12') asciistring1(nt) = trim(asciistring1(nt))//' 6 ' + if (j2.eq.'12') asciistring2(nt) = trim(asciistring2(nt))//' 6 ' + if (j1.eq.'13') asciistring1(nt) = trim(asciistring1(nt))//' 13/2' + if (j2.eq.'13') asciistring2(nt) = trim(asciistring2(nt))//' 13/2' + if (j1.eq.'14') asciistring1(nt) = trim(asciistring1(nt))//' 7 ' + if (j2.eq.'14') asciistring2(nt) = trim(asciistring2(nt))//' 7 ' + if (j1.eq.'15') asciistring1(nt) = trim(asciistring1(nt))//' 15/2' + if (j2.eq.'15') asciistring2(nt) = trim(asciistring2(nt))//' 15/2' + if (j1.eq.'16') asciistring1(nt) = trim(asciistring1(nt))//' 8 ' + if (j2.eq.'16') asciistring2(nt) = trim(asciistring2(nt))//' 8 ' + if (j1.eq.'17') asciistring1(nt) = trim(asciistring1(nt))//' 17/2' + if (j2.eq.'17') asciistring2(nt) = trim(asciistring2(nt))//' 17/2' + if (j1.eq.'18') asciistring1(nt) = trim(asciistring1(nt))//' 9 ' + if (j2.eq.'18') asciistring2(nt) = trim(asciistring2(nt))//' 9 ' + if (j1.eq.'19') asciistring1(nt) = trim(asciistring1(nt))//' 19/2' + if (j2.eq.'19') asciistring2(nt) = trim(asciistring2(nt))//' 19/2' + + if (len_trim(asciistring1(nt)).gt.maxlengthascii1) maxlengthascii1 = len_trim(asciistring1(nt)) + if (len_trim(asciistring2(nt)).gt.maxlengthascii2) maxlengthascii2 = len_trim(asciistring2(nt)) + + end do +999 continue + + do i = 1,nt + if (nformat.eq.1) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//wavelengthstring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.2) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//wavelengthstring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.3) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//wavelengthstring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//'\\' + elseif (nformat.eq.4) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.5) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.6) then + write(19,'(a)') latexstring1(i)(1:maxlengthlatex1)//'~'//extra1(i)//' & '//& + & latexstring2(i)(1:maxlengthlatex2)//'~'//extra2(i)//' & '//& + &energystring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//'\\' + end if + if (nformat.eq.1) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& + &energystring(i)//' '//wavelengthstring(i)//' '//sstring(i)//' '//gfstring(i)//' '//& + &Astring(i)//' '//dTstring(i) + elseif (nformat.eq.2) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& + &energystring(i)//' '//wavelengthstring(i)//' '//gfstring(i)//' '//& + &Astring(i)//' '//dTstring(i) + elseif (nformat.eq.3) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' '// asciistring2(i)(1:maxlengthascii2)//' '//& + &energystring(i)//' '//wavelengthstring(i)//' '//gfstring(i)//' '//& + &Astring(i) + elseif (nformat.eq.4) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& + &energystring(i)//' & '//sstring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.5) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& + &energystring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//' & '//dTstring(i)//'\\' + elseif (nformat.eq.6) then + write(20,'(a)') asciistring1(i)(1:maxlengthascii1)//' & '// asciistring2(i)(1:maxlengthascii2)//' & '//& + &energystring(i)//' & '//gfstring(i)//' & '//& + &Astring(i)//'\\' + end if + end do + +write(19,'(a)') '\hline\\' +write(19,'(a)') '\caption{Transition data from the file '//trim(filename)//'}' +write(19,'(a)') '\end{longtable}' +write(19,'(a)') '\end{document}' + +end do + +end program rtransitiontable + + + diff --git a/src/tool/rwfnmchfmcdf.f90 b/src/tool/rwfnmchfmcdf.f90 index 6857dae30..f51081da7 100644 --- a/src/tool/rwfnmchfmcdf.f90 +++ b/src/tool/rwfnmchfmcdf.f90 @@ -16,7 +16,7 @@ program ff2gr CHARACTER hfcr*4,line*3,atom*6,term*6 integer max(nwf),nl(nwf),l(nwf) -!b +!b !b alpha constant from lib/lib92/setcon.f !b ! COMMON/DEF9/CVAC,PI @@ -41,8 +41,8 @@ program ff2gr do 1 j=1,no+1 pff(j,i)=0.d0 1 continue - - + + do 2 i=0,230 pg(i)=0.d0 qg(i)=0.d0 @@ -90,7 +90,7 @@ program ff2gr ! ***** construct MCHF grid: ! ***** GENERATE ARRAYS FOR R WITH A CONSTANT MESH -! ***** SIZE IN THE LOG(Z*R) VARIABLE +! ***** SIZE IN THE LOG(Z*R) VARIABLE rho = -4.d0 hff = 1.d0/16.d0 @@ -102,7 +102,7 @@ program ff2gr ! ***** construct MCDF grid: ! ***** GENERATE ARRAYS FOR R WITH A CONSTANT MESH -! ***** SIZE IN THE LOG(Z*R) VARIABLE +! ***** SIZE IN THE LOG(Z*R) VARIABLE call grid(z,rg) h = rg(2)/1000.d0 @@ -140,7 +140,7 @@ program ff2gr if (l(m) .ne. 0) then !**************************** -!** first lower j-value: *** +!** first lower j-value: *** !**************************** pqj=real(l(m)-0.5) @@ -180,7 +180,7 @@ program ff2gr write (9) az(m),(pg(i),i=1,myg),(qg(i),i=1,myg) write (9) (rg(i),i=1,myg) -7 continue +7 continue close (1) close (9) stop @@ -193,7 +193,7 @@ subroutine skip(i,line) ! character line*3,irrel*8 data irrel/' ()/\,;:'/ - + 10 if(index(irrel,line(i:i)) .ne. 0 .and. i .lt. 80) then i=i+1 goto 10 @@ -207,11 +207,11 @@ function rdnum(I,line) ! integer rdnum character*3 line - + ! ICHAR('I')-ICHAR('0') RETURNS THE integer VALUE OF A character ! ICHAR('0')=48 or 33 DEPendENT ON THE character SET USED, BUT then ! ICHAR('3')=51 or 36, THE FINAL ANSWER BEING CorRECT - + 10 if(line(2:2).GE.'0'.and.line(2:2).LE.'?')then rdnum=ICHAR(line(2:2))-ICHAR('0') I=3 @@ -222,17 +222,17 @@ function rdnum(I,line) end function function rdorb(i,line) - + ! ! converts character to orbital angular momentum ! integer rdorb character lorbu*1,lorbl*1,line*3 - + dimension lorbu(0:10),lorbl(0:10) data lorbu/'S','P','D','F','G','H','I','K','L','M','N'/ data lorbl/'s','p','d','f','g','h','i','k','l','m','n'/ - + rdorb=0 do 1 ii=0,10 1 if (line (i:i) .eq. lorbl(ii) .or. & @@ -243,7 +243,7 @@ function rdorb(i,line) subroutine GRID(z,rr) ! - IMPLICIT REAL*8(A-H,O-Z) + IMPLICIT REAL*8(A-H,O-Z) DIMENSION RR(230) RNT = EXP (-65.0D00/16.0D00) / Z @@ -281,7 +281,7 @@ SUBROUTINE spline(x,y,n,yp1,ypn,y2) sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) p=sig*y2(i-1)+2.d0 y2(i)=(sig-1.d0)/p - u(i)=(6.d0*((y(i+1)-y(i))/(x(i+ 1) & + u(i)=(6.d0*((y(i+1)-y(i))/(x(i+ 1) & -x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* & u(i-1))/p 11 continue diff --git a/src/tool/rwfnplot.f90 b/src/tool/rwfnplot.f90 index 2168ed298..aaa59b26d 100644 --- a/src/tool/rwfnplot.f90 +++ b/src/tool/rwfnplot.f90 @@ -1,161 +1,161 @@ - PROGRAM rwfnplot - IMPLICIT NONE - - INTEGER, PARAMETER:: NPTS0=5000 - - DOUBLE PRECISION pg(NPTS0), qg(NPTS0), rg(NPTS0), pgg(NPTS0) - DOUBLE PRECISION rg2(NPTS0) - DOUBLE PRECISION energy, a0 - CHARACTER title*6, orbl*4, nnstr*2, new*3, xa*3, el*5 - CHARACTER leg*50, format_string*50, name*100 - DIMENSION el(30) - INTEGER np, lp, jp, nn, laky, ll, jj, npts, j, i, nwf - - write(*,*) 'RWFNPLOT' - write(*,*) 'Program to generate Matlab/GNU Octave and' - write(*,*) 'Xmgrace files that plot radial orbitals' - write(*,*) 'Input file: name.w' - write(*,*) 'Output files: octave_name.m, xmgrace_name.agr' - write(*,*) - write(*,*) 'To plot orbital: press enter' - write(*,*) 'To remove orbital: type "d" or "D" and press enter' - write(*,*) - write(*,*) ' Jorgen Ekman Jun 2015' - write(*,*) - - WRITE(*,*) 'Name of state:' - READ(*,*) name - OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') - OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') - OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') - - write(*,*) - write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r)' - read(*,*) xa - write(*,*) - i = 1 - - write(4,*) '% r P(r) Q(r)' - -! Xmgrace stuff - if(xa.eq.'y ') then - write(8,*) '@ xaxis label "r"' - else - write(8,*) '@ xaxis label "sqrt(r)"' - end if - write(8,*) '@ yaxis label "P(r)"' - write(8,*) '# r P(r) Q(r)' - - write(4,*) 'clf' - READ(3) title - IF (title .NE. 'G92RWF') THEN ! Extra safety - PRINT *, 'title = ', title, 'does not match G92RWF' - STOP - ENDIF - - DO - READ(3, END = 20) nn, laky, energy, npts - write(nnstr,'(I2)') nn - IF (laky .GT. 0) THEN - ll = laky - jj = -1 - ELSEIF (laky .LE. -1) THEN - ll = -laky - 1 - jj = 1 - ELSE - WRITE(*,*)'Unexpected case in reading mcdf.w' - STOP - ENDIF - - if(jj.eq.1) then - if(ll.eq.0) orbl = nnstr//'s ' - if(ll.eq.1) orbl = nnstr//'p ' - if(ll.eq.2) orbl = nnstr//'d ' - if(ll.eq.3) orbl = nnstr//'f ' - if(ll.eq.4) orbl = nnstr//'g ' - if(ll.eq.5) orbl = nnstr//'h ' - if(ll.eq.6) orbl = nnstr//'i ' - if(ll.eq.7) orbl = nnstr//'j ' - if(ll.eq.8) orbl = nnstr//'k ' - if(ll.eq.9) orbl = nnstr//'l ' - else - if(ll.eq.1) orbl = nnstr//'p-' - if(ll.eq.2) orbl = nnstr//'d-' - if(ll.eq.3) orbl = nnstr//'f-' - if(ll.eq.4) orbl = nnstr//'g-' - if(ll.eq.5) orbl = nnstr//'h-' - if(ll.eq.6) orbl = nnstr//'i-' - if(ll.eq.7) orbl = nnstr//'j-' - if(ll.eq.8) orbl = nnstr//'k-' - if(ll.eq.9) orbl = nnstr//'l-' - end if - - IF (npts .GT. NPTS0) THEN - WRITE(*,*) 'df2hf: npts .GT. NPTS0' - STOP - ENDIF - - READ(3) a0, (pg(j), j=1,npts), (qg(j), j=1,npts) - READ(3) (rg(j), j=1,npts) - - WRITE(*,'(2x,A,A,$)') orbl,' = ' - READ(*,'(A)') new - IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN - el(i) = orbl - - ! Xmgrace stuff - if(i-1.lt.10) then - format_string = "(A,I1,3A)" - else - format_string = "(A,I2,3A)" - end if - write (leg,format_string) & - '@ s',i-1,' legend "',el(i),'"' - write(8,*) trim(leg) - write(8,*) '# ',el(i) - - i = i + 1 - write(4,*) 'P = [' - DO j = 1, npts - rg2(j) = sqrt(rg(j)) - if(xa.eq.'y ') then - if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & - WRITE (4, '(3D20.10)') rg(j), pg(j), qg(j) - WRITE (8, '(3D20.10)') rg(j), pg(j), qg(j) - else - if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & - WRITE (4, '(3D20.10)') rg2(j), pg(j), qg(j) - WRITE (8, '(3D20.10)') rg2(j), pg(j), qg(j) - end if - ENDDO - write(8,*) - write(4,*) '];' - write(4,*) 'plot(P(:,1), P(:,2))' - write(4,*) 'hold all' - ENDIF - ENDDO - 20 CONTINUE - nwf = i - 1 - if(xa.eq.'y ') then -! write(4,*) 'xlabel (''r'', ''fontsize'', 12)' - write(4,*) 'xlabel (''r'')' - else -! write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' - write(4,*) 'xlabel (''sqrt(r)'')' - end if -! write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' - write(4,*) 'ylabel (''P(r)'')' - write(4,*) 'grid on' - write(4,101,advance='no') 'legend(' - DO i = 1,nwf - IF(i.LT.nwf) THEN - write(4,102,advance='no') '''',el(i),''',' - ELSE - write(4,102,advance='no') '''',el(i),''')' - END IF - ENDDO - 101 format(a) - 102 format(3a) - PRINT *, ' FINISHED .....' - STOP - END + PROGRAM rwfnplot + IMPLICIT NONE + + INTEGER, PARAMETER:: NPTS0=5000 + + DOUBLE PRECISION pg(NPTS0), qg(NPTS0), rg(NPTS0), pgg(NPTS0) + DOUBLE PRECISION rg2(NPTS0) + DOUBLE PRECISION energy, a0 + CHARACTER title*6, orbl*4, nnstr*2, new*3, xa*3, el*5 + CHARACTER leg*50, format_string*50, name*100 + DIMENSION el(30) + INTEGER np, lp, jp, nn, laky, ll, jj, npts, j, i, nwf + + write(*,*) 'RWFNPLOT' + write(*,*) 'Program to generate Matlab/GNU Octave and' + write(*,*) 'Xmgrace files that plot radial orbitals' + write(*,*) 'Input file: name.w' + write(*,*) 'Output files: octave_name.m, xmgrace_name.agr' + write(*,*) + write(*,*) 'To plot orbital: press enter' + write(*,*) 'To remove orbital: type "d" or "D" and press enter' + write(*,*) + write(*,*) ' Jorgen Ekman Jun 2015' + write(*,*) + + WRITE(*,*) 'Name of state:' + READ(*,*) name + OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') + OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') + OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') + + write(*,*) + write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r)' + read(*,*) xa + write(*,*) + i = 1 + + write(4,*) '% r P(r) Q(r)' + +! Xmgrace stuff + if(xa.eq.'y ') then + write(8,*) '@ xaxis label "r"' + else + write(8,*) '@ xaxis label "sqrt(r)"' + end if + write(8,*) '@ yaxis label "P(r)"' + write(8,*) '# r P(r) Q(r)' + + write(4,*) 'clf' + READ(3) title + IF (title .NE. 'G92RWF') THEN ! Extra safety + PRINT *, 'title = ', title, 'does not match G92RWF' + STOP + ENDIF + + DO + READ(3, END = 20) nn, laky, energy, npts + write(nnstr,'(I2)') nn + IF (laky .GT. 0) THEN + ll = laky + jj = -1 + ELSEIF (laky .LE. -1) THEN + ll = -laky - 1 + jj = 1 + ELSE + WRITE(*,*)'Unexpected case in reading mcdf.w' + STOP + ENDIF + + if(jj.eq.1) then + if(ll.eq.0) orbl = nnstr//'s ' + if(ll.eq.1) orbl = nnstr//'p ' + if(ll.eq.2) orbl = nnstr//'d ' + if(ll.eq.3) orbl = nnstr//'f ' + if(ll.eq.4) orbl = nnstr//'g ' + if(ll.eq.5) orbl = nnstr//'h ' + if(ll.eq.6) orbl = nnstr//'i ' + if(ll.eq.7) orbl = nnstr//'j ' + if(ll.eq.8) orbl = nnstr//'k ' + if(ll.eq.9) orbl = nnstr//'l ' + else + if(ll.eq.1) orbl = nnstr//'p-' + if(ll.eq.2) orbl = nnstr//'d-' + if(ll.eq.3) orbl = nnstr//'f-' + if(ll.eq.4) orbl = nnstr//'g-' + if(ll.eq.5) orbl = nnstr//'h-' + if(ll.eq.6) orbl = nnstr//'i-' + if(ll.eq.7) orbl = nnstr//'j-' + if(ll.eq.8) orbl = nnstr//'k-' + if(ll.eq.9) orbl = nnstr//'l-' + end if + + IF (npts .GT. NPTS0) THEN + WRITE(*,*) 'df2hf: npts .GT. NPTS0' + STOP + ENDIF + + READ(3) a0, (pg(j), j=1,npts), (qg(j), j=1,npts) + READ(3) (rg(j), j=1,npts) + + WRITE(*,'(2x,A,A,$)') orbl,' = ' + READ(*,'(A)') new + IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN + el(i) = orbl + + ! Xmgrace stuff + if(i-1.lt.10) then + format_string = "(A,I1,3A)" + else + format_string = "(A,I2,3A)" + end if + write (leg,format_string) & + '@ s',i-1,' legend "',el(i),'"' + write(8,*) trim(leg) + write(8,*) '# ',el(i) + + i = i + 1 + write(4,*) 'P = [' + DO j = 1, npts + rg2(j) = sqrt(rg(j)) + if(xa.eq.'y ') then + if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & + WRITE (4, '(3D20.10)') rg(j), pg(j), qg(j) + WRITE (8, '(3D20.10)') rg(j), pg(j), qg(j) + else + if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & + WRITE (4, '(3D20.10)') rg2(j), pg(j), qg(j) + WRITE (8, '(3D20.10)') rg2(j), pg(j), qg(j) + end if + ENDDO + write(8,*) + write(4,*) '];' + write(4,*) 'plot(P(:,1), P(:,2))' + write(4,*) 'hold all' + ENDIF + ENDDO + 20 CONTINUE + nwf = i - 1 + if(xa.eq.'y ') then +! write(4,*) 'xlabel (''r'', ''fontsize'', 12)' + write(4,*) 'xlabel (''r'')' + else +! write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' + write(4,*) 'xlabel (''sqrt(r)'')' + end if +! write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' + write(4,*) 'ylabel (''P(r)'')' + write(4,*) 'grid on' + write(4,101,advance='no') 'legend(' + DO i = 1,nwf + IF(i.LT.nwf) THEN + write(4,102,advance='no') '''',el(i),''',' + ELSE + write(4,102,advance='no') '''',el(i),''')' + END IF + ENDDO + 101 format(a) + 102 format(3a) + PRINT *, ' FINISHED .....' + STOP + END diff --git a/src/tool/rwfnrelabel.f90 b/src/tool/rwfnrelabel.f90 index 7433cee6c..9dd8574a6 100644 --- a/src/tool/rwfnrelabel.f90 +++ b/src/tool/rwfnrelabel.f90 @@ -1,195 +1,195 @@ -!*********************************************************************** -! * - PROGRAM RWFNRELABEL -! * -! This program relabels orbitals * -! * -! Written by Per Jonsson, Malmo University 27 March 2014 * -! Ideally, the parameters should be those found in the file * -! The most commonly used parameters are used. * -!*********************************************************************** -! M o d u l e s -!----------------------------------------------- - USE vast_kind_param, ONLY: DOUBLE - USE parameter_def - USE def_C - USE grid_C - USE orb_C - USE wave_C, ONLY: MF, PZ, PF, QF -!----------------------------------------------- -! I n t e r f a c e B l o c k s -!----------------------------------------------- - USE setmc_I - USE setcon_I - USE setcsla_I - USE setiso_I - USE setqic_I - USE radgrd_I - USE setrwfa_I - IMPLICIT NONE - - INTEGER IFIRST, i, j, k, ndef, ncore_not_used, newnp, norb - LOGICAL GETYN, YES - CHARACTER*24 NAME - - CHARACTER*256 FILNAM -! -! - WRITE(*,*) ' RWFNRELABEL' - WRITE(*,*) ' This program relabels radial orbitals' - WRITE(*,*) - WRITE(*,*) ' Input file: name.w' - WRITE(*,*) ' Output file: name_relabel.w' - WRITE(*,*) - - NDEF = 0 - - 10 PRINT *, 'Name of state' - READ(*,'(A)') NAME - K=INDEX(NAME,' ') - IF (K.EQ.1) THEN - PRINT *, 'Names may not start with a blank' - GOTO 10 - ENDIF - FILNAM = NAME(1:K-1)//'_relabel.w' - OPEN(36,FILE=FILNAM,FORM='UNFORMATTED',STATUS = 'UNKNOWN') - WRITE(36) 'G92RWF' - - -! Perform machine- and installation-dependent setup -! - CALL SETMC -! -! Set up the physical constants -! - CALL SETCON -! -! Open, check, load data from, and close, the .csl file -! - CALL SETCSLA(NAME,ncore_not_used) -! -! Read the radial wave functions -! - CALL GETHFD(NAME) - - - WRITE(*,*) - WRITE(*,*) 'Orbitals' - WRITE(*,*) - DO K = 1,NW - WRITE(*,1000) K, NP(K),NH(K) - ENDDO - - WRITE(*,*) 'Total number of orbitals to be relabeled' - READ(*,*) NORB - DO I = 1,NORB - WRITE(*,*) 'Number of the orbital to be relabeled and new n' - READ(*,*) IFIRST,NEWNP - NP(IFIRST) = NEWNP - ENDDO - - -! - DO I = 1,NW - WRITE(36) NP(I),NAK(I),E(I),MF(I) - WRITE(36) PZ(I),(PF(J,I),J = 1,MF(I)),(QF(J,I),J = 1,MF(I)) - WRITE(36) (R(J),J = 1,MF(I)) - ENDDO - - WRITE(*,*) - WRITE(*,*) 'Execution finished' - - -1000 FORMAT(I4,I4,A2) - - CONTAINS - -!*********************************************************************** -! * - SUBROUTINE GETHFD(NAME) -! * -! Interactively determines the data governing the HFS problem. * -! * -! Call(s) to: [LIB92]: NUCPOT, RADGRD, SETQIC. * -! [RCI92]: SETISO, SETRWF. * -! * -! Written by Farid A. Parpia Last revision: 15 Dec 1992 * -! * -!*********************************************************************** -! - IMPLICIT DOUBLEPRECISION (A-H,O-Z) - LOGICAL GETYN,LFORDR,LTRANS,LVP,LSE,LNMS,LSMS,YES - CHARACTER*24 NAME -! - CALL SETISO ('isodata') -! -! Determine the physical effects specifications -! - IF (NDEF.NE.0) THEN - PRINT *, 'The physical speed of light in' - PRINT *, ' atomic units is',CVAC,';' - PRINT *, ' revise this value?' - YES = GETYN () - IF (YES) THEN - PRINT *, 'Enter the revised value:' - READ *,C - ELSE - C = CVAC - ENDIF - ELSE - C = CVAC - ENDIF -! -! Determine the parameters controlling the radial grid -! -! Grid set by SETISO -! IF (NPARM .EQ. 0) THEN -! RNT = EXP (-65.0D 00/16.0D 00) / Z -! H = 0.5D 00**4 -! N = MIN (220,NNNP) -! ELSE -! RNT = 2.0D-06 -! H = 5.0D-02 -! N = NNNP -! ENDIF -! HP = 0.0D 00 - IF (NDEF.NE.0) THEN - PRINT *, 'The default radial grid parameters' - PRINT *, ' for this case are:' - PRINT *, ' RNT = ',RNT,';' - PRINT *, ' H = ',H,';' - PRINT *, ' HP = ',HP,';' - PRINT *, ' N = ',N,';' - PRINT *, ' revise these values?' - YES = GETYN () - IF (YES) THEN - PRINT *, 'Enter RNT:' - READ *, RNT - PRINT *, 'Enter H:' - READ *, H - PRINT *, 'Enter HP:' - READ *, HP - PRINT *, 'Enter N:' - READ *, N - ENDIF - ENDIF -! -! ACCY is an estimate of the accuracy of the numerical procedures -! - ACCY = H**6 -! -! Set up the coefficients for the numerical procedures -! - CALL SETQIC -! -! Generate the radial grid and all associated arrays -! - CALL RADGRD -! -! Load the radial wavefunctions -! - CALL SETRWFA(TRIM(NAME)//'.w') -! - RETURN - END SUBROUTINE - END PROGRAM +!*********************************************************************** +! * + PROGRAM RWFNRELABEL +! * +! This program relabels orbitals * +! * +! Written by Per Jonsson, Malmo University 27 March 2014 * +! Ideally, the parameters should be those found in the file * +! The most commonly used parameters are used. * +!*********************************************************************** +! M o d u l e s +!----------------------------------------------- + USE vast_kind_param, ONLY: DOUBLE + USE parameter_def + USE def_C + USE grid_C + USE orb_C + USE wave_C, ONLY: MF, PZ, PF, QF +!----------------------------------------------- +! I n t e r f a c e B l o c k s +!----------------------------------------------- + USE setmc_I + USE setcon_I + USE setcsla_I + USE setiso_I + USE setqic_I + USE radgrd_I + USE setrwfa_I + IMPLICIT NONE + + INTEGER IFIRST, i, j, k, ndef, ncore_not_used, newnp, norb + LOGICAL GETYN, YES + CHARACTER*24 NAME + + CHARACTER*256 FILNAM +! +! + WRITE(*,*) ' RWFNRELABEL' + WRITE(*,*) ' This program relabels radial orbitals' + WRITE(*,*) + WRITE(*,*) ' Input file: name.w' + WRITE(*,*) ' Output file: name_relabel.w' + WRITE(*,*) + + NDEF = 0 + + 10 PRINT *, 'Name of state' + READ(*,'(A)') NAME + K=INDEX(NAME,' ') + IF (K.EQ.1) THEN + PRINT *, 'Names may not start with a blank' + GOTO 10 + ENDIF + FILNAM = NAME(1:K-1)//'_relabel.w' + OPEN(36,FILE=FILNAM,FORM='UNFORMATTED',STATUS = 'UNKNOWN') + WRITE(36) 'G92RWF' + + +! Perform machine- and installation-dependent setup +! + CALL SETMC +! +! Set up the physical constants +! + CALL SETCON +! +! Open, check, load data from, and close, the .csl file +! + CALL SETCSLA(NAME,ncore_not_used) +! +! Read the radial wave functions +! + CALL GETHFD(NAME) + + + WRITE(*,*) + WRITE(*,*) 'Orbitals' + WRITE(*,*) + DO K = 1,NW + WRITE(*,1000) K, NP(K),NH(K) + ENDDO + + WRITE(*,*) 'Total number of orbitals to be relabeled' + READ(*,*) NORB + DO I = 1,NORB + WRITE(*,*) 'Number of the orbital to be relabeled and new n' + READ(*,*) IFIRST,NEWNP + NP(IFIRST) = NEWNP + ENDDO + + +! + DO I = 1,NW + WRITE(36) NP(I),NAK(I),E(I),MF(I) + WRITE(36) PZ(I),(PF(J,I),J = 1,MF(I)),(QF(J,I),J = 1,MF(I)) + WRITE(36) (R(J),J = 1,MF(I)) + ENDDO + + WRITE(*,*) + WRITE(*,*) 'Execution finished' + + +1000 FORMAT(I4,I4,A2) + + CONTAINS + +!*********************************************************************** +! * + SUBROUTINE GETHFD(NAME) +! * +! Interactively determines the data governing the HFS problem. * +! * +! Call(s) to: [LIB92]: NUCPOT, RADGRD, SETQIC. * +! [RCI92]: SETISO, SETRWF. * +! * +! Written by Farid A. Parpia Last revision: 15 Dec 1992 * +! * +!*********************************************************************** +! + IMPLICIT DOUBLEPRECISION (A-H,O-Z) + LOGICAL GETYN,LFORDR,LTRANS,LVP,LSE,LNMS,LSMS,YES + CHARACTER*24 NAME +! + CALL SETISO ('isodata') +! +! Determine the physical effects specifications +! + IF (NDEF.NE.0) THEN + PRINT *, 'The physical speed of light in' + PRINT *, ' atomic units is',CVAC,';' + PRINT *, ' revise this value?' + YES = GETYN () + IF (YES) THEN + PRINT *, 'Enter the revised value:' + READ *,C + ELSE + C = CVAC + ENDIF + ELSE + C = CVAC + ENDIF +! +! Determine the parameters controlling the radial grid +! +! Grid set by SETISO +! IF (NPARM .EQ. 0) THEN +! RNT = EXP (-65.0D 00/16.0D 00) / Z +! H = 0.5D 00**4 +! N = MIN (220,NNNP) +! ELSE +! RNT = 2.0D-06 +! H = 5.0D-02 +! N = NNNP +! ENDIF +! HP = 0.0D 00 + IF (NDEF.NE.0) THEN + PRINT *, 'The default radial grid parameters' + PRINT *, ' for this case are:' + PRINT *, ' RNT = ',RNT,';' + PRINT *, ' H = ',H,';' + PRINT *, ' HP = ',HP,';' + PRINT *, ' N = ',N,';' + PRINT *, ' revise these values?' + YES = GETYN () + IF (YES) THEN + PRINT *, 'Enter RNT:' + READ *, RNT + PRINT *, 'Enter H:' + READ *, H + PRINT *, 'Enter HP:' + READ *, HP + PRINT *, 'Enter N:' + READ *, N + ENDIF + ENDIF +! +! ACCY is an estimate of the accuracy of the numerical procedures +! + ACCY = H**6 +! +! Set up the coefficients for the numerical procedures +! + CALL SETQIC +! +! Generate the radial grid and all associated arrays +! + CALL RADGRD +! +! Load the radial wavefunctions +! + CALL SETRWFA(TRIM(NAME)//'.w') +! + RETURN + END SUBROUTINE + END PROGRAM diff --git a/src/tool/rwfnrotate.f90 b/src/tool/rwfnrotate.f90 index 89f1b31d5..c9dbd81d9 100644 --- a/src/tool/rwfnrotate.f90 +++ b/src/tool/rwfnrotate.f90 @@ -1,6 +1,6 @@ !*********************************************************************** ! * - PROGRAM RWFNROTATE + PROGRAM RWFNROTATE ! * ! This program rotate orbitals with the same kappa * ! * @@ -41,17 +41,17 @@ PROGRAM RWFNROTATE INTEGER :: i, j, k, MFmax, ncore_not_used REAL(double) :: dummy1, dummy2 ! - + ! - WRITE(*,*) + WRITE(*,*) WRITE(*,*) 'RWFNROTATE' WRITE(*,*) 'This program rotates selected pairs of orbitals' WRITE(*,*) 'It is only meaningful to rotate pairs of orbitals' WRITE(*,*) 'of the same symmetry' - WRITE(*,*) + WRITE(*,*) WRITE(*,*) 'Inputfile : name.w' WRITE(*,*) 'Outputfile: name_rot.w' - WRITE(*,*) + WRITE(*,*) NDEF = 0 @@ -62,7 +62,7 @@ PROGRAM RWFNROTATE PRINT *, 'Names may not start with a blank' GOTO 10 ENDIF - FILNAM = NAME(1:K-1)//'_rot.w' + FILNAM = NAME(1:K-1)//'_rot.w' OPEN(36,FILE=FILNAM,FORM='UNFORMATTED',STATUS = 'UNKNOWN') WRITE(36) 'G92RWF' @@ -98,14 +98,14 @@ PROGRAM RWFNROTATE ! ! Rotate the orbital pair ! - + MFMAX = MAX(MF(IFIRST(1)),MF(IFIRST(2))) DO K = 1,MFMAX DUMMY1 = PF(K,IFIRST(1)) DUMMY2 = PF(K,IFIRST(2)) PF(K,IFIRST(1)) = (DUMMY1 + DUMMY2)/DSQRT(2.d0) PF(K,IFIRST(2)) = (DUMMY2 - DUMMY1)/DSQRT(2.d0) - + DUMMY1 = QF(K,IFIRST(1)) DUMMY2 = QF(K,IFIRST(2)) QF(K,IFIRST(1)) = (DUMMY1 + DUMMY2)/DSQRT(2.d0) @@ -123,7 +123,7 @@ PROGRAM RWFNROTATE IF (YES .eqv. .FALSE.) EXIT ENDDO - + ! DO I = 1,NW WRITE(36) NP(I),NAK(I),E(I),MF(I) @@ -150,7 +150,7 @@ SUBROUTINE GETHFD(NAME) ! * !*********************************************************************** ! - USE vast_kind_param, ONLY: DOUBLE + USE vast_kind_param, ONLY: DOUBLE USE parameter_def, ONLY: NNNW USE decide_C USE def_C diff --git a/src/tool/wfnplot.f90 b/src/tool/wfnplot.f90 index 9b82d6217..b912b4d0d 100644 --- a/src/tool/wfnplot.f90 +++ b/src/tool/wfnplot.f90 @@ -1,126 +1,126 @@ - PROGRAM WFNPLOT - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER AT*6,TT*6,EL1*3,EL*3,NEW*3,INPUT*24,OUTPUT*24, & - ATOM*6,TERM*6,XA*3,OUTPUT2*24,leg*50, & - format_string*50,name*100 - DIMENSION P(220,30),EL(30),R(220),R2(220) -! - write(*,*) '****************************************************' - write(*,*) 'Program wfnplot writes HF/MCHF radial wave functions' - write(*,*) 'to following output files:' - write(*,*) - write(*,*) 'Matlab/GNU Octave file "octave_name.m"' - write(*,*) 'Xmgrace file "xmgrace_name.agr"' - write(*,*) - write(*,*) 'Input file: name.w' - write(*,*) - write(*,*) 'To plot orbital: press enter' - write(*,*) 'To remove orbital: type "d" or "D" and press enter' - write(*,*) - write(*,*) ' Jorgen Ekman Jun 2015' - write(*,*) '****************************************************' - - inc = 1 - - WRITE(*,*) 'Name of state:' - READ(*,*) name - OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') - OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') - OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') - write(*,*) - write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r ' - write(*,*) - read(*,*) XA - - IUF=3 - nwf=1 - MM = 0 -2 P(1,nwf) = 0.D0 - READ(IUF,END=5) AT,TT,EL1,M,ZT,ETI,EKI,AZI,(P(J,NWF),J=2,M+1) - WRITE(6,'(2x,A,A,$)') EL1,' = ' - READ(5,'(A)') NEW - IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN - IF ( NEW .NE. ' ') THEN - EL1 = NEW - ENDIF - EL(NWF) = EL1 - NWF = NWF + 1 - Z = ZT - ATOM = AT - TERM = TT - MM = MAX(M,MM) - END IF - GO TO 2 -5 CLOSE(UNIT=3) - RHO = -4.0 - H = 1/16. - R(1) = 0.d0 - R2(1) = 0.d0 - DO 10 J = 2,220 - R(J) = EXP(RHO)/Z - R2(J) = SQRT(R(J)) - RHO = RHO + H -10 CONTINUE -! -! LIST TABLES OF RADIAL FUNCTIONS -! - NWF = NWF -1 - write(4,*) '% sqrt(r) P(nl;r)' - write(4,*) 'clf' - - if(XA.eq.'y ') then - write(8,*) '@ xaxis label "r"' - else - write(8,*) '@ xaxis label "sqrt(r)"' - end if - write(8,*) '@ yaxis label "P(r)"' - write(8,*) '# sqrt(r) P(nl;r)' - - DO 20 I = 1,NWF - - if(I-1.lt.10) then - format_string = "(A,I1,3A)" - else - format_string = "(A,I2,3A)" - end if - write (leg,format_string) & - '@ s',I-1,' legend "',EL(I),'"' - write(8,*) trim(leg) - write(8,*) '# ',EL(I) - - write(4,*) 'P = [' - DO 21 J = 1,MM,inc - Pwave = P(J,I)*R2(J) - IF(XA.EQ.'y ') THEN - IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & - WRITE(4,'(F10.4,F12.3)') R(J),Pwave - WRITE(8,'(F10.4,F12.3)') R(J),Pwave - ELSE - IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & - WRITE(4,'(F10.4,F12.3)') R2(J),Pwave - WRITE(8,'(F10.4,F12.3)') R2(J),Pwave - END IF - 21 CONTINUE - write(8,*) - write(4,*) '];' - write(4,*) 'plot(P(:,1), P(:,2))' - write(4,*) 'hold all' - 20 CONTINUE - IF(XA.EQ.'y ') THEN - write(4,*) 'xlabel (''r'', ''fontsize'', 12)' - ELSE - write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' - END IF - write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' - write(4,*) 'grid on' - write(4,101,advance='no') 'legend(' - DO 22 I = 1,NWF - IF(I.LT.NWF) THEN - write(4,102,advance='no') '''',EL(I),''',' - ELSE - write(4,102,advance='no') '''',EL(I),''')' - END IF - 22 CONTINUE - 101 format(a) - 102 format(3a) - END + PROGRAM WFNPLOT + IMPLICIT REAL*8(A-H,O-Z) + CHARACTER AT*6,TT*6,EL1*3,EL*3,NEW*3,INPUT*24,OUTPUT*24, & + ATOM*6,TERM*6,XA*3,OUTPUT2*24,leg*50, & + format_string*50,name*100 + DIMENSION P(220,30),EL(30),R(220),R2(220) +! + write(*,*) '****************************************************' + write(*,*) 'Program wfnplot writes HF/MCHF radial wave functions' + write(*,*) 'to following output files:' + write(*,*) + write(*,*) 'Matlab/GNU Octave file "octave_name.m"' + write(*,*) 'Xmgrace file "xmgrace_name.agr"' + write(*,*) + write(*,*) 'Input file: name.w' + write(*,*) + write(*,*) 'To plot orbital: press enter' + write(*,*) 'To remove orbital: type "d" or "D" and press enter' + write(*,*) + write(*,*) ' Jorgen Ekman Jun 2015' + write(*,*) '****************************************************' + + inc = 1 + + WRITE(*,*) 'Name of state:' + READ(*,*) name + OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') + OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') + OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') + write(*,*) + write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r ' + write(*,*) + read(*,*) XA + + IUF=3 + nwf=1 + MM = 0 +2 P(1,nwf) = 0.D0 + READ(IUF,END=5) AT,TT,EL1,M,ZT,ETI,EKI,AZI,(P(J,NWF),J=2,M+1) + WRITE(6,'(2x,A,A,$)') EL1,' = ' + READ(5,'(A)') NEW + IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN + IF ( NEW .NE. ' ') THEN + EL1 = NEW + ENDIF + EL(NWF) = EL1 + NWF = NWF + 1 + Z = ZT + ATOM = AT + TERM = TT + MM = MAX(M,MM) + END IF + GO TO 2 +5 CLOSE(UNIT=3) + RHO = -4.0 + H = 1/16. + R(1) = 0.d0 + R2(1) = 0.d0 + DO 10 J = 2,220 + R(J) = EXP(RHO)/Z + R2(J) = SQRT(R(J)) + RHO = RHO + H +10 CONTINUE +! +! LIST TABLES OF RADIAL FUNCTIONS +! + NWF = NWF -1 + write(4,*) '% sqrt(r) P(nl;r)' + write(4,*) 'clf' + + if(XA.eq.'y ') then + write(8,*) '@ xaxis label "r"' + else + write(8,*) '@ xaxis label "sqrt(r)"' + end if + write(8,*) '@ yaxis label "P(r)"' + write(8,*) '# sqrt(r) P(nl;r)' + + DO 20 I = 1,NWF + + if(I-1.lt.10) then + format_string = "(A,I1,3A)" + else + format_string = "(A,I2,3A)" + end if + write (leg,format_string) & + '@ s',I-1,' legend "',EL(I),'"' + write(8,*) trim(leg) + write(8,*) '# ',EL(I) + + write(4,*) 'P = [' + DO 21 J = 1,MM,inc + Pwave = P(J,I)*R2(J) + IF(XA.EQ.'y ') THEN + IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & + WRITE(4,'(F10.4,F12.3)') R(J),Pwave + WRITE(8,'(F10.4,F12.3)') R(J),Pwave + ELSE + IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & + WRITE(4,'(F10.4,F12.3)') R2(J),Pwave + WRITE(8,'(F10.4,F12.3)') R2(J),Pwave + END IF + 21 CONTINUE + write(8,*) + write(4,*) '];' + write(4,*) 'plot(P(:,1), P(:,2))' + write(4,*) 'hold all' + 20 CONTINUE + IF(XA.EQ.'y ') THEN + write(4,*) 'xlabel (''r'', ''fontsize'', 12)' + ELSE + write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' + END IF + write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' + write(4,*) 'grid on' + write(4,101,advance='no') 'legend(' + DO 22 I = 1,NWF + IF(I.LT.NWF) THEN + write(4,102,advance='no') '''',EL(I),''',' + ELSE + write(4,102,advance='no') '''',EL(I),''')' + END IF + 22 CONTINUE + 101 format(a) + 102 format(3a) + END From 55eb57b84b14737cf15f2f16418faaf0b8c0d147 Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Tue, 2 Apr 2019 11:31:05 +0200 Subject: [PATCH 04/57] Minor update of environment files (#13) * rename environment files * Synchronized and updated/generalized the env files The environoment files are updated with a common header, and the flags have been updated to be slightly more generalized to fit the general user (i.e. per and cff home folders are replaced with the $HOME env variable) * Changed intel mpi compiler to recommended wrapper An intel mpi comilation should be done with the wrapper mpiifort, and not mpifort, as stated in the intel documentation [1] [1] https://software.intel.com/en-us/mpi-developer-reference-linux-compilation-commands * GRASP2K --> GRASP Co-Authored-By: jongrumer * GRASP2K --> GRASP Co-Authored-By: jongrumer * Add missing "_" in LD_LIB.. Co-Authored-By: jongrumer * Add missing "_" in LD_LIB... flag. Co-Authored-By: jongrumer * Short installation requirements and fixed MPI_TMP Added a short installation requirements list and modded MPI_TMP to grasp_mpi_tmp according to @mortenpi's suggestion. * Short installation requirements and fixed MPI_TMP Added a short installation requirement list and modified MPI_TMP according to @mortenpi's suggestion. --- ..._gfortran_UBC => make_environment_gfortran | 26 +++++++-------- make_environment_ifort | 29 +++++++++++++++++ make_environment_ifort_CC | 32 ------------------- 3 files changed, 41 insertions(+), 46 deletions(-) rename make_environment_gfortran_UBC => make_environment_gfortran (64%) create mode 100755 make_environment_ifort delete mode 100755 make_environment_ifort_CC diff --git a/make_environment_gfortran_UBC b/make_environment_gfortran similarity index 64% rename from make_environment_gfortran_UBC rename to make_environment_gfortran index f8a8e5ab0..16caba378 100755 --- a/make_environment_gfortran_UBC +++ b/make_environment_gfortran @@ -1,31 +1,29 @@ #!/bin/bash -# ------------------------------------------------------------------------------------------------------------------------------------- -# GRASP2K ENVIRONMENT FLAGS -# ------------------------------------------------------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------------------------------------- +# GRASP ENVIRONMENT FLAGS - GNU gfortran version +# ------------------------------------------------------------------------------------------------------------------- # # Define the following global variables according to your environment and # source this script or add these definitions to your terminal configuration # file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. # -# Current version: Linux, gfortran gcc version 5.4.0 +# Installation requirements: +# - Lapack, Blas and MPI libraries have to be installed and properly linked - e.g. add them to LD_LIBRARY_PATH. +# - The Fortran compiler of choice and the MPI wrapper (as specified by FC and FC_MPI below) have to be on your PATH. # -# Assumes gfortran, openmpi are on PATH -# Assumes openmpi libraries on LD_LIBRARY PATH -# files liblapack.a and libblas.a are added to $GRASP/lib - -# ----------------------------------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------------------------------------- # Set up main flags -# ----------------------------------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------------------------------------- export FC=gfortran # Fortran compiler export FC_FLAGS="-O2 -fno-automatic " # Serial code compiler flags export FC_LD=" " # Serial linker flags export GRASP="${PWD}" # Location of the 2018 root directory export LAPACK_LIBS="-llapack -lblas" # Lapack libraries -# ----------------------------------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------------------------------------- # Set up MPI related flags -# ----------------------------------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------------------------------------- export FC_MPI="mpifort" # MPI export FC_MPIFLAGS="${FC_FLAGS}" # Parallel code compiler flags export FC_MPILD=${FC_LD} # Serial linker flags -# ----------------------------------------------------------------------------------------------------------------- -export MPI_TMP="/home/per/tmp_mpi" # Location for temporary files +# ------------------------------------------------------------------------------------------------------------------- +export MPI_TMP="${HOME}/grasp_mpi_tmp" # Location for temporary files diff --git a/make_environment_ifort b/make_environment_ifort new file mode 100755 index 000000000..de63b04b0 --- /dev/null +++ b/make_environment_ifort @@ -0,0 +1,29 @@ +#!/bin/bash +# ------------------------------------------------------------------------------------------------------------------- +# GRASP ENVIRONMENT FLAGS - Intel ifort version +# ------------------------------------------------------------------------------------------------------------------- +# +# Define the following global variables according to your environment and +# source this script or add these definitions to your terminal configuration +# file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. +# +# Installation requirements: +# - Lapack, Blas and MPI libraries have to be installed and properly linked - e.g. add them to LD_LIBRARY_PATH. +# - The Fortran compiler of choice and the MPI wrapper (as specified by FC and FC_MPI below) have to be on your PATH. +# +# ------------------------------------------------------------------------------------------------------------------- +# Set up main flags +# ------------------------------------------------------------------------------------------------------------------- +export FC=ifort # Fortran compiler +export FC_FLAGS="-O2 -save " # Serial code compiler flags +export FC_LD="-mkl=sequential" # Serial linker flags +export GRASP="${PWD}" # Location of the 2018 root directory +export LAPACK_LIBS="-llapack -lblas" # Lapack libraries +# ------------------------------------------------------------------------------------------------------------------- +# Set up MPI related flags +# ------------------------------------------------------------------------------------------------------------------- +export FC_MPI="mpiifort" # MPI +export FC_MPIFLAGS="${FC_FLAGS}" # Parallel code compiler flags +export FC_MPILD=${FC_LD} # Serial linker flags +# ------------------------------------------------------------------------------------------------------------------- +export MPI_TMP="${HOME}/grasp_mpi_tmp" # Location for temporary files diff --git a/make_environment_ifort_CC b/make_environment_ifort_CC deleted file mode 100755 index 81d562d68..000000000 --- a/make_environment_ifort_CC +++ /dev/null @@ -1,32 +0,0 @@ -#!/bin/bash -# -------------------------------------------------------------------------------------- -# GRASP2K ENVIRONMENT FLAGS -# -------------------------------------------------------------------------------------- -# -# Define the following global variables according to your environment and -# source this script or add these definitions to your terminal configuration -# file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. -# -# Current version: Linux, gfortran gcc version 4.8.2 -# -# -# Assumes ifort compiler on the path -# libraries invoked through a compiler option - -# -------------------------------------------------------------------------------------- -# Set up main flags -# -------------------------------------------------------------------------------------- -export FC=ifort # Fortran compiler -export FC_FLAGS="-O2 -save " # Serial code compiler flags -#export FC_FLAGS="-O0 -check all" # Options for check for runtime errors -export FC_LD="-mkl=sequential" # Serial linker flags -export LAPACK_LIB=" " # Library to be searched (not needed for ifort) -export GRASP="${PWD}" # Location of the grasp2k root directory -# -------------------------------------------------------------------------------------- -# Set up MPI related flags -# -------------------------------------------------------------------------------------- -export FC_MPI="mpifort" # MPI -export FC_MPIFLAGS="${FC_FLAGS}" # Parallel code compiler flags -export FC_MPILD="-mkl=sequential" # Serical linker flags -# -------------------------------------------------------------------------------------- -export MPI_TMP="/scratch/cff/case1" # Location of directory for temporary files From 5fc284e2aaaf5c41bb8e9f725dc4efd2b56e5e4c Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Sat, 13 Apr 2019 20:19:15 +1200 Subject: [PATCH 05/57] Change license text to standard OSI MIT (#15) By removing the "except the above mentioned practical guide GRASP2018". This is so that automated systems, such as the one used by GitHub, could recognize that this indeed is the MIT license. None of the rights or restrictions granted by the license were changed, so the updated wording does not change the spirit of the license in any way. It is clear that "associated documentation files" does not refer to the separate manual, as the manual is not part of the repository and has its own copyright and license statement. --- LICENSE | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/LICENSE b/LICENSE index e48d4df5e..2276bff2b 100644 --- a/LICENSE +++ b/LICENSE @@ -2,21 +2,19 @@ MIT License Copyright (c) 2018 Computational Atomic Structure Group -Permission is hereby granted, free of charge, to any person obtaining a -copy of this software and associated documentation files -except the above mentioned practical guide GRASP2018 (the "Software"), -to deal in the Software without restriction, including without limitation -the rights to use, copy, modify, merge, publish, distribute, sublicense, -and/or sell copies of the Software, and to permit persons to whom the -Software is furnished to do so, subject to the following conditions: +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. From 3a07ca18305cb11cb6988736a70dfc698321a60b Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Sat, 1 Jun 2019 14:32:35 +0200 Subject: [PATCH 06/57] Added Gediminas rwfnplot fix + some formatting Both these codes are written in a mixed F77 style which should be adressed at some point. --- src/tool/rwfnplot.f90 | 323 +++++++++++++++++++++--------------------- src/tool/wfnplot.f90 | 215 ++++++++++++++-------------- 2 files changed, 271 insertions(+), 267 deletions(-) diff --git a/src/tool/rwfnplot.f90 b/src/tool/rwfnplot.f90 index aaa59b26d..6db51d151 100644 --- a/src/tool/rwfnplot.f90 +++ b/src/tool/rwfnplot.f90 @@ -1,161 +1,162 @@ - PROGRAM rwfnplot - IMPLICIT NONE - - INTEGER, PARAMETER:: NPTS0=5000 - - DOUBLE PRECISION pg(NPTS0), qg(NPTS0), rg(NPTS0), pgg(NPTS0) - DOUBLE PRECISION rg2(NPTS0) - DOUBLE PRECISION energy, a0 - CHARACTER title*6, orbl*4, nnstr*2, new*3, xa*3, el*5 - CHARACTER leg*50, format_string*50, name*100 - DIMENSION el(30) - INTEGER np, lp, jp, nn, laky, ll, jj, npts, j, i, nwf - - write(*,*) 'RWFNPLOT' - write(*,*) 'Program to generate Matlab/GNU Octave and' - write(*,*) 'Xmgrace files that plot radial orbitals' - write(*,*) 'Input file: name.w' - write(*,*) 'Output files: octave_name.m, xmgrace_name.agr' - write(*,*) - write(*,*) 'To plot orbital: press enter' - write(*,*) 'To remove orbital: type "d" or "D" and press enter' - write(*,*) - write(*,*) ' Jorgen Ekman Jun 2015' - write(*,*) - - WRITE(*,*) 'Name of state:' - READ(*,*) name - OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') - OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') - OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') - - write(*,*) - write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r)' - read(*,*) xa - write(*,*) - i = 1 - - write(4,*) '% r P(r) Q(r)' - -! Xmgrace stuff - if(xa.eq.'y ') then - write(8,*) '@ xaxis label "r"' - else - write(8,*) '@ xaxis label "sqrt(r)"' - end if - write(8,*) '@ yaxis label "P(r)"' - write(8,*) '# r P(r) Q(r)' - - write(4,*) 'clf' - READ(3) title - IF (title .NE. 'G92RWF') THEN ! Extra safety - PRINT *, 'title = ', title, 'does not match G92RWF' - STOP - ENDIF - - DO - READ(3, END = 20) nn, laky, energy, npts - write(nnstr,'(I2)') nn - IF (laky .GT. 0) THEN - ll = laky - jj = -1 - ELSEIF (laky .LE. -1) THEN - ll = -laky - 1 - jj = 1 - ELSE - WRITE(*,*)'Unexpected case in reading mcdf.w' - STOP - ENDIF - - if(jj.eq.1) then - if(ll.eq.0) orbl = nnstr//'s ' - if(ll.eq.1) orbl = nnstr//'p ' - if(ll.eq.2) orbl = nnstr//'d ' - if(ll.eq.3) orbl = nnstr//'f ' - if(ll.eq.4) orbl = nnstr//'g ' - if(ll.eq.5) orbl = nnstr//'h ' - if(ll.eq.6) orbl = nnstr//'i ' - if(ll.eq.7) orbl = nnstr//'j ' - if(ll.eq.8) orbl = nnstr//'k ' - if(ll.eq.9) orbl = nnstr//'l ' - else - if(ll.eq.1) orbl = nnstr//'p-' - if(ll.eq.2) orbl = nnstr//'d-' - if(ll.eq.3) orbl = nnstr//'f-' - if(ll.eq.4) orbl = nnstr//'g-' - if(ll.eq.5) orbl = nnstr//'h-' - if(ll.eq.6) orbl = nnstr//'i-' - if(ll.eq.7) orbl = nnstr//'j-' - if(ll.eq.8) orbl = nnstr//'k-' - if(ll.eq.9) orbl = nnstr//'l-' - end if - - IF (npts .GT. NPTS0) THEN - WRITE(*,*) 'df2hf: npts .GT. NPTS0' - STOP - ENDIF - - READ(3) a0, (pg(j), j=1,npts), (qg(j), j=1,npts) - READ(3) (rg(j), j=1,npts) - - WRITE(*,'(2x,A,A,$)') orbl,' = ' - READ(*,'(A)') new - IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN - el(i) = orbl - - ! Xmgrace stuff - if(i-1.lt.10) then - format_string = "(A,I1,3A)" - else - format_string = "(A,I2,3A)" - end if - write (leg,format_string) & - '@ s',i-1,' legend "',el(i),'"' - write(8,*) trim(leg) - write(8,*) '# ',el(i) - - i = i + 1 - write(4,*) 'P = [' - DO j = 1, npts - rg2(j) = sqrt(rg(j)) - if(xa.eq.'y ') then - if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & - WRITE (4, '(3D20.10)') rg(j), pg(j), qg(j) - WRITE (8, '(3D20.10)') rg(j), pg(j), qg(j) - else - if (abs(pg(j)) .gt. 0.0005 .OR. j.EQ.1) & - WRITE (4, '(3D20.10)') rg2(j), pg(j), qg(j) - WRITE (8, '(3D20.10)') rg2(j), pg(j), qg(j) - end if - ENDDO - write(8,*) - write(4,*) '];' - write(4,*) 'plot(P(:,1), P(:,2))' - write(4,*) 'hold all' - ENDIF - ENDDO - 20 CONTINUE - nwf = i - 1 - if(xa.eq.'y ') then -! write(4,*) 'xlabel (''r'', ''fontsize'', 12)' - write(4,*) 'xlabel (''r'')' - else -! write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' - write(4,*) 'xlabel (''sqrt(r)'')' - end if -! write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' - write(4,*) 'ylabel (''P(r)'')' - write(4,*) 'grid on' - write(4,101,advance='no') 'legend(' - DO i = 1,nwf - IF(i.LT.nwf) THEN - write(4,102,advance='no') '''',el(i),''',' - ELSE - write(4,102,advance='no') '''',el(i),''')' - END IF - ENDDO - 101 format(a) - 102 format(3a) - PRINT *, ' FINISHED .....' - STOP - END +PROGRAM rwfnplot + IMPLICIT NONE + + INTEGER, PARAMETER:: NPTS0 = 5000 + + DOUBLE PRECISION pg(NPTS0), qg(NPTS0), rg(NPTS0), pgg(NPTS0) + DOUBLE PRECISION rg2(NPTS0) + DOUBLE PRECISION energy, a0 + CHARACTER title*6, orbl*4, nnstr*2, new*3, xa*3, el*5 + CHARACTER leg*50, format_string*50, name*100 + DIMENSION el(30) + INTEGER np, lp, jp, nn, laky, ll, jj, npts, j, i, nwf + + write (*, *) 'RWFNPLOT' + write (*, *) 'Program to generate Matlab/GNU Octave and' + write (*, *) 'Xmgrace files that plot radial orbitals' + write (*, *) 'Input file: name.w' + write (*, *) 'Output files: octave_name.m, xmgrace_name.agr' + write (*, *) + write (*, *) 'To plot orbital: press enter' + write (*, *) 'To remove orbital: type "d" or "D" and press enter' + write (*, *) + write (*, *) ' Jorgen Ekman Jun 2015' + write (*, *) + + WRITE (*, *) 'Name of state:' + READ (*, *) name + OPEN (3, FILE=trim(name)//'.w', STATUS='OLD', FORM='UNFORMATTED') + OPEN (4, FILE='octave_'//trim(name)//'.m', STATUS='UNKNOWN') + OPEN (8, FILE='xmgrace_'//trim(name)//'.agr', STATUS='UNKNOWN') + + write (*, *) + write (*, *) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r)' + read (*, *) xa + write (*, *) + i = 1 + + write (4, *) '% r P(r) Q(r)' + + ! Xmgrace stuff + if (xa .eq. 'y ') then + write (8, *) '@ xaxis label "r"' + else + write (8, *) '@ xaxis label "sqrt(r)"' + end if + write (8, *) '@ yaxis label "P(r)"' + write (8, *) '# r P(r) Q(r)' + + write (4, *) 'clf' + READ (3) title + IF (title .NE. 'G92RWF') THEN ! Extra safety + PRINT *, 'title = ', title, 'does not match G92RWF' + STOP + ENDIF + + DO + READ (3, END=20) nn, laky, energy, npts + write (nnstr, '(I2)') nn + IF (laky .GT. 0) THEN + ll = laky + jj = -1 + ELSEIF (laky .LE. -1) THEN + ll = -laky - 1 + jj = 1 + ELSE + WRITE (*, *) 'Unexpected case in reading mcdf.w' + STOP + ENDIF + + if (jj .eq. 1) then + if (ll .eq. 0) orbl = nnstr//'s ' + if (ll .eq. 1) orbl = nnstr//'p ' + if (ll .eq. 2) orbl = nnstr//'d ' + if (ll .eq. 3) orbl = nnstr//'f ' + if (ll .eq. 4) orbl = nnstr//'g ' + if (ll .eq. 5) orbl = nnstr//'h ' + if (ll .eq. 6) orbl = nnstr//'i ' + if (ll .eq. 7) orbl = nnstr//'k ' + if (ll .eq. 8) orbl = nnstr//'l ' + if (ll .eq. 9) orbl = nnstr//'m ' + else + if (ll .eq. 1) orbl = nnstr//'p-' + if (ll .eq. 2) orbl = nnstr//'d-' + if (ll .eq. 3) orbl = nnstr//'f-' + if (ll .eq. 4) orbl = nnstr//'g-' + if (ll .eq. 5) orbl = nnstr//'h-' + if (ll .eq. 6) orbl = nnstr//'i-' + if (ll .eq. 7) orbl = nnstr//'k-' + if (ll .eq. 8) orbl = nnstr//'l-' + if (ll .eq. 9) orbl = nnstr//'m-' + end if + + IF (npts .GT. NPTS0) THEN + WRITE (*, *) 'df2hf: npts .GT. NPTS0' + STOP + ENDIF + + READ (3) a0, (pg(j), j=1, npts), (qg(j), j=1, npts) + READ (3) (rg(j), j=1, npts) + + WRITE (*, '(2x,A,A,$)') orbl, ' = ' + READ (*, '(A)') new + IF (NEW .NE. 'd ' .AND. NEW .NE. 'D ') THEN + el(i) = orbl + + ! Xmgrace stuff + if (i - 1 .lt. 10) then + format_string = "(A,I1,3A)" + else + format_string = "(A,I2,3A)" + end if + write (leg, format_string) & + '@ s', i - 1, ' legend "', el(i), '"' + write (8, *) trim(leg) + write (8, *) '# ', el(i) + + i = i + 1 + write (4, *) 'P = [' + DO j = 1, npts + rg2(j) = sqrt(rg(j)) + if (xa .eq. 'y ') then + if (abs(pg(j)) .gt. 0.0005 .OR. j .EQ. 1) & + WRITE (4, '(3D20.10)') rg(j), pg(j), qg(j) + WRITE (8, '(3D20.10)') rg(j), pg(j), qg(j) + else + if (abs(pg(j)) .gt. 0.0005 .OR. j .EQ. 1) & + WRITE (4, '(3D20.10)') rg2(j), pg(j), qg(j) + WRITE (8, '(3D20.10)') rg2(j), pg(j), qg(j) + end if + ENDDO + write (8, *) + write (4, *) '];' + write (4, *) 'plot(P(:,1), P(:,2))' + write (4, *) 'hold all' + ENDIF + ENDDO + +20 CONTINUE + + nwf = i - 1 + + if (xa .eq. 'y ') then + write (4, *) 'xlabel (''r'')' + else + write (4, *) 'xlabel (''sqrt(r)'')' + end if + + write (4, *) 'ylabel (''P(r)'')' + write (4, *) 'grid on' + write (4, 101, advance='no') 'legend(' + DO i = 1, nwf + IF (i .LT. nwf) THEN + write (4, 102, advance='no') '''', el(i), ''',' + ELSE + write (4, 102, advance='no') '''', el(i), ''')' + END IF + ENDDO +101 format(a) +102 format(3a) + PRINT *, ' Finished.' + STOP +END diff --git a/src/tool/wfnplot.f90 b/src/tool/wfnplot.f90 index b912b4d0d..25c5ac766 100644 --- a/src/tool/wfnplot.f90 +++ b/src/tool/wfnplot.f90 @@ -1,126 +1,129 @@ - PROGRAM WFNPLOT - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER AT*6,TT*6,EL1*3,EL*3,NEW*3,INPUT*24,OUTPUT*24, & - ATOM*6,TERM*6,XA*3,OUTPUT2*24,leg*50, & - format_string*50,name*100 - DIMENSION P(220,30),EL(30),R(220),R2(220) -! - write(*,*) '****************************************************' - write(*,*) 'Program wfnplot writes HF/MCHF radial wave functions' - write(*,*) 'to following output files:' - write(*,*) - write(*,*) 'Matlab/GNU Octave file "octave_name.m"' - write(*,*) 'Xmgrace file "xmgrace_name.agr"' - write(*,*) - write(*,*) 'Input file: name.w' - write(*,*) - write(*,*) 'To plot orbital: press enter' - write(*,*) 'To remove orbital: type "d" or "D" and press enter' - write(*,*) - write(*,*) ' Jorgen Ekman Jun 2015' - write(*,*) '****************************************************' +PROGRAM WFNPLOT - inc = 1 + IMPLICIT REAL*8(A - H, O - Z) + CHARACTER AT*6, TT*6, EL1*3, EL*3, NEW*3, INPUT*24, OUTPUT*24, & + ATOM*6, TERM*6, XA*3, OUTPUT2*24, leg*50, & + format_string*50, name*100 + DIMENSION P(220, 30), EL(30), R(220), R2(220) - WRITE(*,*) 'Name of state:' - READ(*,*) name - OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED') - OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN') - OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN') - write(*,*) - write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r ' - write(*,*) - read(*,*) XA + write (*, *) '****************************************************' + write (*, *) 'Program wfnplot writes HF/MCHF radial wave functions' + write (*, *) 'to following output files:' + write (*, *) + write (*, *) 'Matlab/GNU Octave file "octave_name.m"' + write (*, *) 'Xmgrace file "xmgrace_name.agr"' + write (*, *) + write (*, *) 'Input file: name.w' + write (*, *) + write (*, *) 'To plot orbital: press enter' + write (*, *) 'To remove orbital: type "d" or "D" and press enter' + write (*, *) + write (*, *) ' Jorgen Ekman Jun 2015' + write (*, *) '****************************************************' - IUF=3 - nwf=1 - MM = 0 -2 P(1,nwf) = 0.D0 - READ(IUF,END=5) AT,TT,EL1,M,ZT,ETI,EKI,AZI,(P(J,NWF),J=2,M+1) - WRITE(6,'(2x,A,A,$)') EL1,' = ' - READ(5,'(A)') NEW - IF ( NEW .NE. 'd ' .AND. NEW .NE. 'D ' ) THEN - IF ( NEW .NE. ' ') THEN - EL1 = NEW - ENDIF - EL(NWF) = EL1 - NWF = NWF + 1 - Z = ZT - ATOM = AT - TERM = TT - MM = MAX(M,MM) - END IF - GO TO 2 -5 CLOSE(UNIT=3) - RHO = -4.0 - H = 1/16. - R(1) = 0.d0 - R2(1) = 0.d0 - DO 10 J = 2,220 - R(J) = EXP(RHO)/Z - R2(J) = SQRT(R(J)) - RHO = RHO + H + inc = 1 + + WRITE (*, *) 'Name of state:' + READ (*, *) name + OPEN (3, FILE=trim(name)//'.w', STATUS='OLD', FORM='UNFORMATTED') + OPEN (4, FILE='octave_'//trim(name)//'.m', STATUS='UNKNOWN') + OPEN (8, FILE='xmgrace_'//trim(name)//'.agr', STATUS='UNKNOWN') + write (*, *) + write (*, *) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r ' + write (*, *) + read (*, *) XA + + IUF = 3 + nwf = 1 + MM = 0 +2 P(1, nwf) = 0.D0 + READ (IUF, END=5) AT, TT, EL1, M, ZT, ETI, EKI, AZI, (P(J, NWF), J=2, M + 1) + WRITE (6, '(2x,A,A,$)') EL1, ' = ' + READ (5, '(A)') NEW + IF (NEW .NE. 'd ' .AND. NEW .NE. 'D ') THEN + IF (NEW .NE. ' ') THEN + EL1 = NEW + ENDIF + EL(NWF) = EL1 + NWF = NWF + 1 + Z = ZT + ATOM = AT + TERM = TT + MM = MAX(M, MM) + END IF + GO TO 2 +5 CLOSE (UNIT=3) + RHO = -4.0 + H = 1/16. + R(1) = 0.d0 + R2(1) = 0.d0 + DO 10 J = 2, 220 + R(J) = EXP(RHO)/Z + R2(J) = SQRT(R(J)) + RHO = RHO + H 10 CONTINUE ! -! LIST TABLES OF RADIAL FUNCTIONS +! LIST TABLES OF RADIAL FUNCTIONS ! - NWF = NWF -1 - write(4,*) '% sqrt(r) P(nl;r)' - write(4,*) 'clf' + NWF = NWF - 1 + write (4, *) '% sqrt(r) P(nl;r)' + write (4, *) 'clf' - if(XA.eq.'y ') then - write(8,*) '@ xaxis label "r"' + if (XA .eq. 'y ') then + write (8, *) '@ xaxis label "r"' else - write(8,*) '@ xaxis label "sqrt(r)"' + write (8, *) '@ xaxis label "sqrt(r)"' end if - write(8,*) '@ yaxis label "P(r)"' - write(8,*) '# sqrt(r) P(nl;r)' + write (8, *) '@ yaxis label "P(r)"' + write (8, *) '# sqrt(r) P(nl;r)' - DO 20 I = 1,NWF + DO 20 I = 1, NWF - if(I-1.lt.10) then + if (I - 1 .lt. 10) then format_string = "(A,I1,3A)" else format_string = "(A,I2,3A)" end if - write (leg,format_string) & - '@ s',I-1,' legend "',EL(I),'"' - write(8,*) trim(leg) - write(8,*) '# ',EL(I) + write (leg, format_string) & + '@ s', I - 1, ' legend "', EL(I), '"' + write (8, *) trim(leg) + write (8, *) '# ', EL(I) - write(4,*) 'P = [' - DO 21 J = 1,MM,inc - Pwave = P(J,I)*R2(J) - IF(XA.EQ.'y ') THEN - IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & - WRITE(4,'(F10.4,F12.3)') R(J),Pwave - WRITE(8,'(F10.4,F12.3)') R(J),Pwave + write (4, *) 'P = [' + DO 21 J = 1, MM, inc + Pwave = P(J, I)*R2(J) + IF (XA .EQ. 'y ') THEN + IF (abs(Pwave) .gt. 0.0005 .OR. J .EQ. 1) & + WRITE (4, '(F10.4,F12.3)') R(J), Pwave + WRITE (8, '(F10.4,F12.3)') R(J), Pwave ELSE - IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) & - WRITE(4,'(F10.4,F12.3)') R2(J),Pwave - WRITE(8,'(F10.4,F12.3)') R2(J),Pwave + IF (abs(Pwave) .gt. 0.0005 .OR. J .EQ. 1) & + WRITE (4, '(F10.4,F12.3)') R2(J), Pwave + WRITE (8, '(F10.4,F12.3)') R2(J), Pwave END IF - 21 CONTINUE - write(8,*) - write(4,*) '];' - write(4,*) 'plot(P(:,1), P(:,2))' - write(4,*) 'hold all' - 20 CONTINUE - IF(XA.EQ.'y ') THEN - write(4,*) 'xlabel (''r'', ''fontsize'', 12)' +21 CONTINUE + write (8, *) + write (4, *) '];' + write (4, *) 'plot(P(:,1), P(:,2))' + write (4, *) 'hold all' +20 CONTINUE + IF (XA .EQ. 'y ') THEN + write (4, *) 'xlabel (''r'', ''fontsize'', 12)' ELSE - write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' + write (4, *) 'xlabel (''sqrt(r)'', ''fontsize'', 12)' END IF - write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)' - write(4,*) 'grid on' - write(4,101,advance='no') 'legend(' - DO 22 I = 1,NWF - IF(I.LT.NWF) THEN - write(4,102,advance='no') '''',EL(I),''',' - ELSE - write(4,102,advance='no') '''',EL(I),''')' - END IF - 22 CONTINUE - 101 format(a) - 102 format(3a) - END + write (4, *) 'ylabel (''P(r)'', ''fontsize'', 12)' + write (4, *) 'grid on' + write (4, 101, advance='no') 'legend(' + DO 22 I = 1, NWF + IF (I .LT. NWF) THEN + write (4, 102, advance='no') '''', EL(I), ''',' + ELSE + write (4, 102, advance='no') '''', EL(I), ''')' + END IF +22 CONTINUE + +101 format(a) +102 format(3a) + +END PROGRAM WFNPLOT From 3ef41d082f8a1b122c15738314a9a94c902fa170 Mon Sep 17 00:00:00 2001 From: jfbabb <52377620+jfbabb@users.noreply.github.com> Date: Tue, 2 Jul 2019 02:04:02 -0400 Subject: [PATCH 07/57] Update clean (#20) Minor change of example4 to enable cleaning of tmp_mpi files --- grasptest/example4/script/clean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/grasptest/example4/script/clean b/grasptest/example4/script/clean index 84b574b0f..faaf43f79 100755 --- a/grasptest/example4/script/clean +++ b/grasptest/example4/script/clean @@ -19,6 +19,6 @@ rm energylabel* rm *.pdf rm *.tex rm *.aux -cd ../tmp_mpi +cd ./tmp_mpi rm */* cd .. From 827a31fd19b9ceb1af55bbb4b9c31c3178e835d2 Mon Sep 17 00:00:00 2001 From: jfbabb <52377620+jfbabb@users.noreply.github.com> Date: Tue, 2 Jul 2019 02:53:30 -0400 Subject: [PATCH 08/57] Update rasfsplit.f90 (#21) Added typedef for system --- src/tool/rasfsplit.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tool/rasfsplit.f90 b/src/tool/rasfsplit.f90 index afda1ea57..51ab11931 100644 --- a/src/tool/rasfsplit.f90 +++ b/src/tool/rasfsplit.f90 @@ -7,6 +7,7 @@ program rasfsplit integer :: npos,i,j,k,l,ios,nblock,nblockodd,nblockeven integer :: nelec,ncftot,nw,nvectot,nvecsize integer :: nb,nevblk(100),iatjp,iaspa,ivec(100) +integer :: system integer, allocatable :: ncfblk(:) double precision :: eav,eval(100) From 46811621d9e9254cb474343c4ac5a7fcc77804bd Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Mon, 8 Jul 2019 17:41:13 +0200 Subject: [PATCH 09/57] Patch July 2019 (#19) ## CFF Patch: Improving RMCDHF and extending terms to J = 17/2 (l, m-) In May @cffischer sent me a collection of updates, fixes and general improvements that I've put together into a single patch. The most important fixes are related to how the Lagrange multipliers are calculated in RMCDHF, and she has also extended the allowed terms on step to `J=17/2 (l, m-)`. I've also added some minor fixes to the rwfnmchfmcdf code and the ldlbl1 and 2 files in the transition codes which should remove some warnings during compilation. Check the patch out and see what you think, review the code and let's get back to this in a week or so for merging. A description of the mods by Charlotte follows. /Jon ### Patch summary (CFF) 'RMCDHF' is not robust in that accurate initial estimates are needed. When algorithms fail, the messages are misleading, and in some instances the program simply stops. Several changes have been introduced that increase the robustness and the efficiency. ### Tests The changes have been tested for a correlation study for Li 1s(2)2s(1) J=1/2 for wavefunctions from SDT excitations to nl=9l. ### Libmod - increase J of allowed terms. 1) `terms_C.f90` Changes have been introduced that increase the maximum `J` to 17/2 or `l` or `m-`. ### Lib9290 - joining point evaluation has been improved 1) `setpot.f90` This routine uses an algorithm that involves the orbital energy for finding a join. When the energy estimate is such that the criteria for the join is not met, the program STOPS. The `STOP` has been replaced by `JP=NNNP/2`. This sets the join to be the middle of the grid. 2) `start.90` Remove the comment about accuracy because the problem is not related to accuracy and is misleading. ### RMCDHF 1) `setlag.f90` and `setlagmpi.f90` There was a logical error in the section determining Lagrange multilpliers. When two subshells are both varied the solution is not unique so the desired solution is one where the lagrange multiplier is zero. But as soon as the orbitals for one is fixed, a lagrange multiplier is needed. Also, the order of the lagrange multipliers were not in the most efficient order. The calculation of Lagrange multipliers in the CSF procedure for heavy elements is the most time consuming task particularly the calculation of the exchange term. The order of computation has been modified so that POTL and XCH functions are called the minimum number of times. In Francine (Fr) 45 calls to exchange were reduced to 30 call.`When Correlation is included, XCH function includes contributions from all the interactions as well as exchange. 2) `in.f90` When the algorithm for finding the outward boundary condition did not find an end-point, because of poor initial estimates an error message claimed the range was insufficient. In the present code it is defined to be `NNNP-1`. An appropriate "end point" is determined in subsequent iterations. The range `NNNP=590` has been found adequate for all test cases. ### Tools - increase dimension of the tools codes Many of the routines in the `tool` library, do not use the GRASP parameters for determining dimensions and are subject to error. In particular, "lines" of input data have character dimension of 100. For heavy elements, this may not be sufficient and the program does not detect that information is lost. The two corrected cases are, 1) `rmixaccumulate.f90` 2) `rmixextract.f90` but there are probably more. Actually, it is not a correction really since this just changes `100 => 200`. But there are several other cases that probably also are wrong. Unless someone else updates the online GRASP2018 code, Charlotte said she will do that as soon, possibly this summer. `rmixextract.f90` also had another error that she fixed. ## Additional fixes (JG) 1) `tools/rwfnmchfmcdf.f90` Bugfix: initialization loop of arrays were done in an old fashioned style, but also from element 0 which gave a warning during compilation. This is now changed to simple `A = 0` statements. 2) `rtransition(_mpi)/ldlbl1(2).f90` Fixed legacy-style read statements. --- src/appl/rmcdhf90/in.f90 | 3 +- src/appl/rmcdhf90/setlag.f90 | 106 +++++++++----------------- src/appl/rmcdhf90_mpi/in.f90 | 3 +- src/appl/rmcdhf90_mpi/setlagmpi.f90 | 105 ++++++------------------- src/appl/rtransition90/ldlbl1.f90 | 2 +- src/appl/rtransition90/ldlbl2.f90 | 2 +- src/appl/rtransition90_mpi/ldlbl1.f90 | 2 +- src/appl/rtransition90_mpi/ldlbl2.f90 | 2 +- src/lib/lib9290/setpot.f90 | 9 ++- src/lib/lib9290/start.f90 | 2 - src/lib/libmod/terms_C.f90 | 17 ++++- src/tool/rmixaccumulate.f90 | 11 +-- src/tool/rmixextract.f90 | 8 +- src/tool/rwfnmchfmcdf.f90 | 16 +--- 14 files changed, 100 insertions(+), 188 deletions(-) diff --git a/src/appl/rmcdhf90/in.f90 b/src/appl/rmcdhf90/in.f90 index fe5e888d9..e4ff4d339 100644 --- a/src/appl/rmcdhf90/in.f90 +++ b/src/appl/rmcdhf90/in.f90 @@ -72,7 +72,6 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) ! ! Global initializations ! -!ww EPS = 0.1D 00*ACCY EPS = 0.01D00*ACCY HHK = 0.5D00*H*DBLE(NAK(IORB)) ! @@ -143,7 +142,7 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) ! TLAST = TTHIS TTHIS = ABS(XS(I)/TI(I)) - IF (TTHIS + TLAST <= EPS) THEN + IF (TTHIS + TLAST <= EPS .OR. J .EQ. NNNP-1 ) THEN MTP = J ELSE GO TO 1 diff --git a/src/appl/rmcdhf90/setlag.f90 b/src/appl/rmcdhf90/setlag.f90 index a35f8337d..9b206f278 100644 --- a/src/appl/rmcdhf90/setlag.f90 +++ b/src/appl/rmcdhf90/setlag.f90 @@ -56,11 +56,11 @@ SUBROUTINE SETLAG(EOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, & + INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLJ, LJRAW, LJ, IECCLI, L1, L2, & JLAST, MLAST, M, J, I REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM REAL(DOUBLE) :: EPS, UCFJ, UCFM, RESULT, RIJM, QDIF, OBQDIF, OBQSUM - LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ + LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ, VLI, VLJ !----------------------------------------------- ! DATA FIRST/ .TRUE./ @@ -85,65 +85,28 @@ SUBROUTINE SETLAG(EOL) EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied DO ITWICE = 1, 2 NEC = 0 -! IF (ITWICE /= 2) THEN -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS -! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! CYCLE -! !*** Encode index at 2nd round *** -! END DO -! END DO -! ELSE -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! !*** Encode index at 2nd round *** -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS -! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! !*** Encode index at 2nd round *** -! IECC(NEC) = LI + KEY*LJ -! END DO -! END DO -! ENDIF - DO LIraw = 1, NW - 1 - LI = iorder(LIraw) - LIP1 = MAX (NCORE, LIraw) + 1 - NAKLI = NAK(LI) - FIXLI = LFIX(LI) - FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS - DO LJraw = LIP1, NW + DO LJraw = NCORE+1, NW LJ = iorder(LJraw) - FIXLJ = LFIX(LJ) + NAKLJ = NAK(LJ) + VLJ = .NOT. LFIX(LJ) FULLJ = ABS ( UCF(LJ)-DBLE (NKJ(LJ)+1) ) .LT. EPS - IF ( (NAK(LJ) .EQ. NAKLI) .AND. & - (.NOT. (FIXLI .AND. FIXLJ)) .AND. & - (.NOT. (FULLI .AND. FULLJ)) ) THEN + DO LIraw = 1, LJraw-1 + LI = iorder(LIraw) + VLI = .NOT. LFIX(LI) + FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS + IF (NAK(LI) .EQ. NAKLJ) then + If (VLI .OR. VLJ ) then ! at least one orbital varied +! but not both (varied and full) + If (.NOT. ((VLI .AND. VLJ) .AND. (FULLI .AND. FULLJ))) THEN NEC = NEC + 1 !*** Encode index at 2nd round *** IF (itwice == 2) IECC(NEC) = LI + KEY * LJ ENDIF + ENDIF + ENDIF ENDDO ENDDO - IF (ITWICE==1 .AND. NEC>0) THEN CALL ALLOC (ECV, NEC, 'ECV', 'SETLAG') CALL ALLOC (IECC, NEC, 'IECC', 'SETLAG') @@ -173,7 +136,6 @@ SUBROUTINE SETLAG(EOL) FIRST = .FALSE. ENDIF -!FF+GG 12/07/05 ! Lagrange multipliers need to be computed also on the first call ! RETURN @@ -217,11 +179,12 @@ SUBROUTINE SETLAG(EOL) IF (LFIX(M)) THEN TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I& - ,J)+QF(I,M)*QF(I,J))*YPJ(I)) + TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+ & + (PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))*YPJ(I)) END DO CALL QUAD (RESULT) +! note ..rinti(m,j,1) is symmetric in (j,m) RIJM = RINTI(M,J,1) ECV(LI) = (RESULT - RIJM)*UCFJ @@ -236,8 +199,8 @@ SUBROUTINE SETLAG(EOL) ELSE IF (LFIX(J)) THEN TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I& - ,M)+QF(I,J)*QF(I,M))*YPM(I)) + TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+ & + (PF(I,J)*PF(I,M)+QF(I,J)*QF(I,M))*YPM(I)) END DO !start dbg @@ -258,20 +221,22 @@ SUBROUTINE SETLAG(EOL) ! WRITE (81,*)RESULT, RIJM, UCFJ, ECV, r(i), rp(i) !end dbg - ELSE + QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) + IF (QDIF > P001) THEN OBQDIF = 1.D0/UCFJ - 1.D0/UCFM TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I& - )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) + TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I) & + -PF(I,J)*XQM(I)+QF(I,J)*XPM(I))*C & + +(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))) END DO CALL QUAD (RESULT) ECV(LI) = RESULT/OBQDIF + !start dbg ! WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA' ! WRITE (81,*)RESULT, OBQDIF, ECV @@ -280,19 +245,22 @@ SUBROUTINE SETLAG(EOL) ! ENDDO !end dbg - ELSE + OBQSUM = 1.D0/UCFJ + 1.D0/UCFM + TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I& - )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) + TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I) & + +PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C & + +(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))) END DO CALL QUAD (RESULT) - RIJM = RINTI(M,J,1) !/ nprocs - ECV(LI) = (RESULT - 2.D0*RIJM)/OBQSUM + RIJM = RINTI(M,J,1) + ECV(LI) = (RESULT - 2.0*RIJM)/OBQSUM + + !start dbg ! WRITE (81,*)'4, RESULT, RIUJM, OBQSUM, ECV, TA' ! WRITE (81,*)RESULT, RIUJM, OBQSUM, ECV @@ -308,10 +276,6 @@ SUBROUTINE SETLAG(EOL) END DO -!db close(81) -!db close(82) - - 302 FORMAT(/,'Lagrange multipliers are not required') 304 FORMAT(/,'Include Lagrange multipliers between:'/) 305 FORMAT(13X,2(2X,1I2,1A2)) diff --git a/src/appl/rmcdhf90_mpi/in.f90 b/src/appl/rmcdhf90_mpi/in.f90 index fe5e888d9..a8a677fe9 100644 --- a/src/appl/rmcdhf90_mpi/in.f90 +++ b/src/appl/rmcdhf90_mpi/in.f90 @@ -143,7 +143,8 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP) ! TLAST = TTHIS TTHIS = ABS(XS(I)/TI(I)) - IF (TTHIS + TLAST <= EPS) THEN +!cff Stop if J=NNNP + IF (TTHIS + TLAST <= EPS .OR. J .EQ. NNNP-1 ) THEN MTP = J ELSE GO TO 1 diff --git a/src/appl/rmcdhf90_mpi/setlagmpi.f90 b/src/appl/rmcdhf90_mpi/setlagmpi.f90 index e7ebaf54c..dddbc963a 100644 --- a/src/appl/rmcdhf90_mpi/setlagmpi.f90 +++ b/src/appl/rmcdhf90_mpi/setlagmpi.f90 @@ -56,11 +56,11 @@ SUBROUTINE SETLAGmpi(EOL) !----------------------------------------------- ! L o c a l V a r i a b l e s !----------------------------------------------- - INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, & + INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLJ, LJRAW, LJ, IECCLI, L1, L2, & JLAST, MLAST, M, J, I REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM REAL(DOUBLE) :: EPS,UCFJ,UCFM,RESULT,RIJM,QDIF,OBQDIF,OBQSUM,TMP - LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ + LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ, VLI, VLJ !----------------------------------------------- ! DATA FIRST/ .TRUE./ @@ -85,61 +85,25 @@ SUBROUTINE SETLAGmpi(EOL) EPS = ACCY*0.01D0 ! criterion to see if an orb is occupied DO ITWICE = 1, 2 NEC = 0 -! IF (ITWICE /= 2) THEN -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS -! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! CYCLE -! !*** Encode index at 2nd round *** -! END DO -! END DO -! ELSE -! DO LIRAW = 1, NW - 1 -! LI = IORDER(LIRAW) -! LIP1 = MAX(NCORE,LIRAW) + 1 -! NAKLI = NAK(LI) -! FIXLI = LFIX(LI) -! FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS -! !*** Encode index at 2nd round *** -! DO LJRAW = LIP1, NW -! LJ = IORDER(LJRAW) -! FIXLJ = LFIX(LJ) -! FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS -! IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)& -! .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE -! NEC = NEC + 1 -! !*** Encode index at 2nd round *** -! IECC(NEC) = LI + KEY*LJ -! END DO -! END DO -! ENDIF - DO LIraw = 1, NW - 1 - LI = iorder(LIraw) - LIP1 = MAX (NCORE, LIraw) + 1 - NAKLI = NAK(LI) - FIXLI = LFIX(LI) - FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS - DO LJraw = LIP1, NW + DO LJraw = NCORE+1, NW LJ = iorder(LJraw) - FIXLJ = LFIX(LJ) + NAKLJ = NAK(LJ) + VLJ = .NOT. LFIX(LJ) FULLJ = ABS ( UCF(LJ)-DBLE (NKJ(LJ)+1) ) .LT. EPS - IF ( (NAK(LJ) .EQ. NAKLI) .AND. & - (.NOT. (FIXLI .AND. FIXLJ)) .AND. & - (.NOT. (FULLI .AND. FULLJ)) ) THEN + DO LIraw = 1, LJraw-1 + LI = iorder(LIraw) + VLI = .NOT. LFIX(LI) + FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS + IF (NAK(LI) .EQ. NAKLJ) then + If (VLI .OR. VLJ ) then !at least one varid +! ! but not (both varied and full) + If (.NOT. ((VLI .AND. VLJ) .AND. (FULLI .AND. FULLJ))) THEN NEC = NEC + 1 !*** Encode index at 2nd round *** IF (itwice == 2) IECC(NEC) = LI + KEY * LJ ENDIF + ENDIF + ENDIF ENDDO ENDDO @@ -217,8 +181,8 @@ SUBROUTINE SETLAGmpi(EOL) IF (LFIX(M)) THEN TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I& - ,J)+QF(I,M)*QF(I,J))*YPJ(I)) + TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+ & + (PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))*YPJ(I)) END DO CALL QUAD (RESULT) @@ -235,9 +199,8 @@ SUBROUTINE SETLAGmpi(EOL) ELSE IF (LFIX(J)) THEN TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I& - ,M)+QF(I,J)*QF(I,M))*YPM(I)) -!GG write(222,*)"XQM(I)",XQM(I) + TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+ & + (PF(I,J)*PF(I,M)+QF(I,J)*QF(I,M))*YPM(I)) END DO !start dbg @@ -260,34 +223,12 @@ SUBROUTINE SETLAGmpi(EOL) ELSE - QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM)) - IF (QDIF > P001) THEN - OBQDIF = 1.D0/UCFJ - 1.D0/UCFM - TA(1) = 0.D0 - DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I& - )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) - END DO - - CALL QUAD (RESULT) - ECV(LI) = RESULT/OBQDIF -!start dbg -! WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA' -! WRITE (81,*)RESULT, OBQDIF, ECV -! DO i = 1, MTP -! WRITE (81,*) i, TA(i), r(i), rp(i) -! ENDDO -!end dbg - - - ELSE OBQSUM = 1.D0/UCFJ + 1.D0/UCFM TA(1) = 0.D0 DO I = 2, MTP - TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I& - )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,& - M)*QF(I,J))) + TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I) & + +PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C & + +(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))) END DO CALL QUAD (RESULT) @@ -301,7 +242,7 @@ SUBROUTINE SETLAGmpi(EOL) ! ENDDO !end dbg - ENDIF +! ENDIF ENDIF !======================================================================= ! Collect contributions from all nodes. diff --git a/src/appl/rtransition90/ldlbl1.f90 b/src/appl/rtransition90/ldlbl1.f90 index dddf9c6d5..ec800d412 100644 --- a/src/appl/rtransition90/ldlbl1.f90 +++ b/src/appl/rtransition90/ldlbl1.f90 @@ -59,7 +59,7 @@ SUBROUTINE LDLBL1 (NAME) ! READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF1(ICount) ! - 2 READ (31,'(1X,I2)',IOSTAT = IOS),ITEST + 2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST IF (IOS .NE. 0) GO TO 1 IF (ITEST .EQ. 0) GO TO 2 BACKSPACE 31 diff --git a/src/appl/rtransition90/ldlbl2.f90 b/src/appl/rtransition90/ldlbl2.f90 index ca121ddc4..a5c0bf712 100644 --- a/src/appl/rtransition90/ldlbl2.f90 +++ b/src/appl/rtransition90/ldlbl2.f90 @@ -59,7 +59,7 @@ SUBROUTINE LDLBL2 (NAME) ! READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF2(ICount) ! - 2 READ (31,'(1X,I2)',IOSTAT = IOS),ITEST + 2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST IF (IOS .NE. 0) GO TO 1 IF (ITEST .EQ. 0) GO TO 2 BACKSPACE 31 diff --git a/src/appl/rtransition90_mpi/ldlbl1.f90 b/src/appl/rtransition90_mpi/ldlbl1.f90 index 6f1cc75ec..1e57239f5 100644 --- a/src/appl/rtransition90_mpi/ldlbl1.f90 +++ b/src/appl/rtransition90_mpi/ldlbl1.f90 @@ -60,7 +60,7 @@ SUBROUTINE LDLBL1 (NAME) ! READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF1(ICount) ! - 2 READ (31,'(1X,I2)',IOSTAT = IOS),ITEST + 2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST IF (IOS .NE. 0) GO TO 1 IF (ITEST .EQ. 0) GO TO 2 BACKSPACE 31 diff --git a/src/appl/rtransition90_mpi/ldlbl2.f90 b/src/appl/rtransition90_mpi/ldlbl2.f90 index e6329c70a..249421fa8 100644 --- a/src/appl/rtransition90_mpi/ldlbl2.f90 +++ b/src/appl/rtransition90_mpi/ldlbl2.f90 @@ -59,7 +59,7 @@ SUBROUTINE LDLBL2 (NAME) ! READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF2(ICount) ! - 2 READ (31,'(1X,I2)',IOSTAT = IOS),ITEST + 2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST IF (IOS .NE. 0) GO TO 1 IF (ITEST .EQ. 0) GO TO 2 BACKSPACE 31 diff --git a/src/lib/lib9290/setpot.f90 b/src/lib/lib9290/setpot.f90 index 99504f3c1..ad6140124 100644 --- a/src/lib/lib9290/setpot.f90 +++ b/src/lib/lib9290/setpot.f90 @@ -5,6 +5,11 @@ SUBROUTINE SETPOT(J, JP) ! This subroutine sets up the arrays TF and TG for use by the * ! subprograms IN, OUT, and SBSTEP. * ! * +! The routine uses an algorithm that involves the orbital energy for * +! finding a join. When the energy estimate is such that the * +! criteria for the join is not met, the program sets the joining * +! point in the middle of the grid. * +! * ! Arguments: * ! * ! J: (Input) Index of orbital * @@ -71,8 +76,8 @@ SUBROUTINE SETPOT(J, JP) ! Trap for inappropriate grid ! IF (JP == 0) THEN - WRITE (ISTDE, *) 'SETPOT: Grid of insufficient extent.' - STOP + WRITE (ISTDE, *) 'SETPOT: Join set to NNNP/2 = ', nnnp/2 + JP = NNNP/2 ENDIF ! RETURN diff --git a/src/lib/lib9290/start.f90 b/src/lib/lib9290/start.f90 index cb697bf78..b710aa2a2 100644 --- a/src/lib/lib9290/start.f90 +++ b/src/lib/lib9290/start.f90 @@ -199,8 +199,6 @@ SUBROUTINE START(IORB, ITYPE, P0, P, Q0, Q) IF (DIFMAX > ACCY) THEN IF (NITER < MXITER) THEN GO TO 7 - ELSE - WRITE (*, 300) NP(IORB), NH(IORB), DIFMAX, NITER, ACCY ENDIF ENDIF ! ELSE diff --git a/src/lib/libmod/terms_C.f90 b/src/lib/libmod/terms_C.f90 index d21c7c54c..322b6f9ad 100644 --- a/src/lib/libmod/terms_C.f90 +++ b/src/lib/libmod/terms_C.f90 @@ -8,12 +8,12 @@ MODULE terms_C !...Modified by Charlotte Froese Fischer ! Gediminas Gaigalas 10/05/17 implicit none - INTEGER, DIMENSION(31) :: ITAB - INTEGER, DIMENSION(32) :: JTAB - INTEGER, DIMENSION(327) :: NTAB + INTEGER, DIMENSION(39) :: ITAB + INTEGER, DIMENSION(40) :: JTAB + INTEGER, DIMENSION(357) :: NTAB INTEGER :: NROWS INTEGER, PRIVATE :: i - DATA NROWS/ 31/ + DATA NROWS/ 39/ ! ! A row is defined by a subshell angular momentum and an occupation ! number @@ -101,4 +101,13 @@ MODULE terms_C DATA (JTAB(I),I=30,32)/ 300, 303, 328/ DATA (NTAB(I),I=301,327)/ 1, 0, 16, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, & 2, 0, 17, 2, 0, 21, 2, 0, 25, 2, 0, 29/ +! +! l, m- (j = 17/2) +! +! First two rows only +! + DATA (ITAB(I),I=38,39)/ 1, 9/ + DATA (JTAB(I),I=38,40)/ 327, 330, 358/ + DATA (NTAB(I),I=328,357)/ 1, 0, 18, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, & + 2, 0, 17, 2, 0, 21, 2, 0, 25, 2, 0, 29, 2, 0, 33/ END MODULE terms_C diff --git a/src/tool/rmixaccumulate.f90 b/src/tool/rmixaccumulate.f90 index 1f1f15a35..90532db31 100644 --- a/src/tool/rmixaccumulate.f90 +++ b/src/tool/rmixaccumulate.f90 @@ -1,10 +1,11 @@ program rmixaccumulate + implicit none integer :: i,ii,j,jj,k,kk,l,ios,err integer :: nelec, ncftot, nw, nvectot, nvecsize, nblock - integer :: nb, nevblk(100), iatjp, iaspa + integer :: nb, nevblk(200), iatjp, iaspa integer :: ivec - integer :: nrelorb, indexans, co(100) + integer :: nrelorb, indexans, co(200) integer, allocatable :: checkcsf(:,:), ind(:,:), ind2(:,:), ncfblk(:) integer, allocatable :: ncfblockout(:) @@ -12,12 +13,12 @@ program rmixaccumulate double precision :: dc2evec, totc2evecblk, c2evecblklim double precision, allocatable :: evec(:,:,:),c2evec(:,:) - character(len=100) :: state, file1, file2 + character(len=200) :: state, file1, file2 character(len=600) :: header(5), string - character(len=5) :: relorbitals(100) + character(len=5) :: relorbitals(200) character(len=6) :: G92MIX character(len=1) :: ciflag,sortflag - character(len=100), allocatable :: conf(:,:), coupling(:,:), spin(:,:) + character(len=200), allocatable :: conf(:,:), coupling(:,:), spin(:,:) write(*,*) '***************************************************************************' write(*,*) 'Welcome to program rmixaccumulate' write(*,*) diff --git a/src/tool/rmixextract.f90 b/src/tool/rmixextract.f90 index cb8109dfc..4205397c1 100644 --- a/src/tool/rmixextract.f90 +++ b/src/tool/rmixextract.f90 @@ -6,7 +6,8 @@ PROGRAM extmix USE iounit_C IMPLICIT DOUBLE PRECISION (a-h, o-z) - CHARACTER*100, line(3), g92mix*6, head*500 + CHARACTER*200, line(3) + CHARACTER*100, g92mix*6, head*500 CHARACTER*64 StrInput, basnam, from*1, suffix*3, filnam*69, dotc*2 LOGICAL sort, getyn, first_of_the_block DATA nfmix,nfcsf,nfout,nfscratch/20,21,22,23/ @@ -74,7 +75,8 @@ PROGRAM extmix ! ...Sort or not - PRINT*,'Sort extracted CSFs according to mixingcoeffcients? (y/n)' +! CFF .. send to screen rather than printer + WRITE (istde,*) 'Sort extracted CSFs according to mixingcoeffcients? (y/n)' sort = getyn() !*********************************************************************** @@ -258,7 +260,7 @@ SUBROUTINE iocsf (nfcsf, nfscratch, jblock, ncfblk, line) CHARACTER*(*) line(3), star*2 OPEN (nfscratch, STATUS = 'SCRATCH', ACCESS = 'DIRECT', & - RECL = 300) + RECL = 600) DO icf = 1, ncfblk READ (nfcsf,'(A)') line(1) diff --git a/src/tool/rwfnmchfmcdf.f90 b/src/tool/rwfnmchfmcdf.f90 index f51081da7..984583d1b 100644 --- a/src/tool/rwfnmchfmcdf.f90 +++ b/src/tool/rwfnmchfmcdf.f90 @@ -35,19 +35,11 @@ program ff2gr ! u write out initial orbitals Pnl and Qnl as input ! u for Grant's MCDF program ! u ******************************************************************* -! - Z=0.0 - do 1 i=1,nwf - do 1 j=1,no+1 - pff(j,i)=0.d0 -1 continue - - - do 2 i=0,230 - pg(i)=0.d0 - qg(i)=0.d0 -2 continue + Z = 0.d0 + pff = 0.d0 + pg = 0.d0 + qg = 0.d0 write(9) 'G92RWF' ! From 7291d2fce6008dfbc2c4d5c7d2902c4e4c884761 Mon Sep 17 00:00:00 2001 From: Jon Grumer Date: Tue, 29 Oct 2019 16:07:33 +0100 Subject: [PATCH 10/57] Increased char length in rcsfsplit --- .gitignore | 2 ++ src/tool/rcsfsplit.f90 | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 69353dc26..015657697 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ +*.out +*.err *.o *.mod lib/* diff --git a/src/tool/rcsfsplit.f90 b/src/tool/rcsfsplit.f90 index b9b8229a2..ac8c3b59a 100644 --- a/src/tool/rcsfsplit.f90 +++ b/src/tool/rcsfsplit.f90 @@ -5,11 +5,11 @@ program rcsfsplit implicit none integer :: i, j, k, n, nlayer, norb, norblayer, nsymmetrymatch, norbcomp, ncsf, nwrite, ncount integer :: jr, jl, pos, ncsflist(50) -character(len=100) :: string1, string2, string3, name +character(len=200) :: string1, string2, string3, name character(len=1500) :: orbitalstring character(len=3) :: orb(300),orbital(25),orbcomp(300) character(len=4) :: orbrel(300) -character(len=100) :: orbitallayer,label(50) +character(len=200) :: orbitallayer,label(50) write(*,*) 'RCSFSPLIT' write(*,*) 'Splits a list name.c of CSFs into a number of lists with CSFs that ' From 88e074df71241215ad6e78d7ad93b284187ed7df Mon Sep 17 00:00:00 2001 From: SachaSchiffmann <33343624+SachaSchiffmann@users.noreply.github.com> Date: Thu, 5 Dec 2019 18:13:00 +0100 Subject: [PATCH 11/57] Changing the call to LAPACK LIBS in the Makefile (#32) --- src/tool/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tool/Makefile b/src/tool/Makefile index 04936da00..f673851fa 100644 --- a/src/tool/Makefile +++ b/src/tool/Makefile @@ -7,7 +7,7 @@ MODDIR = ${SRCLIBDIR}/libmod MODL9290 = ${SRCLIBDIR}/lib9290 GRASPLIBS = -l9290 -lmod -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} -llapack -lblas +APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} ${LAPACK_LIBS} UTIL = rcsfsplit rmixaccumulate rseqenergy \ rseqhfs rseqtrans rtablevels rtabtransE1 \ From c4e66d299cf3ad6d30c402641b90c8f8cc7dcdca Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Wed, 29 Jan 2020 10:34:43 +1300 Subject: [PATCH 12/57] Add CMake-based build files (#25) Support both CMake and the old Make-based approach. Both can be automatically generated using the BUILDCONF.sh scripts to make sure that they stay up to date. Also enable GitHub Actions CI that checks that everything is up to date, the code compiles (with both Make and CMake) and that the test suite passes. --- .github/workflows/buildfiles.yml | 13 + .github/workflows/buildmake.yml | 19 ++ .github/workflows/test.yml | 23 ++ .gitignore | 18 +- CMakeLists.txt | 182 ++++++++++++++ README.md | 90 ++++++- configure.sh | 50 ++++ contrib/checkbin.sh | 86 +++++++ contrib/genbuild.sh | 260 ++++++++++++++++++++ contrib/genbuildall.sh | 35 +++ src/Makefile | 2 +- src/appl/HF/BUILDCONF.sh | 4 + src/appl/HF/CMakeLists.txt | 4 + src/appl/HF/Makefile | 24 +- src/appl/jj2lsj90/BUILDCONF.sh | 13 + src/appl/jj2lsj90/CMakeLists.txt | 17 ++ src/appl/jj2lsj90/Makefile | 72 ++---- src/appl/jjgen90/BUILDCONF.sh | 43 ++++ src/appl/jjgen90/CMakeLists.txt | 55 +++++ src/appl/jjgen90/Makefile | 90 ++++--- src/appl/rangular90/BUILDCONF.sh | 26 ++ src/appl/rangular90/CMakeLists.txt | 33 +++ src/appl/rangular90/Makefile | 81 +++--- src/appl/rangular90_mpi/BUILDCONF.sh | 22 ++ src/appl/rangular90_mpi/CMakeLists.txt | 31 +++ src/appl/rangular90_mpi/Makefile | 80 +++--- src/appl/rbiotransform90/BUILDCONF.sh | 54 ++++ src/appl/rbiotransform90/CMakeLists.txt | 87 +++++++ src/appl/rbiotransform90/Makefile | 132 +++++++--- src/appl/rbiotransform90_mpi/BUILDCONF.sh | 55 +++++ src/appl/rbiotransform90_mpi/CMakeLists.txt | 87 +++++++ src/appl/rbiotransform90_mpi/Makefile | 134 +++++++--- src/appl/rci90/BUILDCONF.sh | 93 +++++++ src/appl/rci90/CMakeLists.txt | 136 ++++++++++ src/appl/rci90/Makefile | 196 +++++++++++---- src/appl/rci90_mpi/BUILDCONF.sh | 87 +++++++ src/appl/rci90_mpi/CMakeLists.txt | 140 +++++++++++ src/appl/rci90_mpi/Makefile | 207 +++++++++++----- src/appl/rcsfgenerate90/BUILDCONF.sh | 42 ++++ src/appl/rcsfgenerate90/CMakeLists.txt | 58 +++++ src/appl/rcsfgenerate90/Makefile | 99 +++++--- src/appl/rcsfinteract90/BUILDCONF.sh | 34 +++ src/appl/rcsfinteract90/CMakeLists.txt | 49 ++++ src/appl/rcsfinteract90/Makefile | 104 ++++---- src/appl/rcsfzerofirst90/BUILDCONF.sh | 11 + src/appl/rcsfzerofirst90/CMakeLists.txt | 13 + src/appl/rcsfzerofirst90/Makefile | 56 ++--- src/appl/rhfs90/BUILDCONF.sh | 18 ++ src/appl/rhfs90/CMakeLists.txt | 24 ++ src/appl/rhfs90/Makefile | 60 ++--- src/appl/rmcdhf90/BUILDCONF.sh | 65 +++++ src/appl/rmcdhf90/CMakeLists.txt | 114 +++++++++ src/appl/rmcdhf90/Makefile | 164 ++++++++---- src/appl/rmcdhf90_mpi/BUILDCONF.sh | 69 ++++++ src/appl/rmcdhf90_mpi/CMakeLists.txt | 117 +++++++++ src/appl/rmcdhf90_mpi/Makefile | 176 +++++++++---- src/appl/rnucleus90/BUILDCONF.sh | 10 + src/appl/rnucleus90/CMakeLists.txt | 11 + src/appl/rnucleus90/Makefile | 39 ++- src/appl/rtransition90/BUILDCONF.sh | 51 ++++ src/appl/rtransition90/CMakeLists.txt | 83 +++++++ src/appl/rtransition90/Makefile | 130 +++++++--- src/appl/rtransition90_mpi/BUILDCONF.sh | 51 ++++ src/appl/rtransition90_mpi/CMakeLists.txt | 83 +++++++ src/appl/rtransition90_mpi/Makefile | 130 +++++++--- src/appl/rwfnestimate90/BUILDCONF.sh | 24 ++ src/appl/rwfnestimate90/CMakeLists.txt | 37 +++ src/appl/rwfnestimate90/Makefile | 81 +++--- src/appl/sms90/BUILDCONF.sh | 30 +++ src/appl/sms90/CMakeLists.txt | 44 ++++ src/appl/sms90/Makefile | 85 ++++--- src/lib/lib9290/BUILDCONF.sh | 81 ++++++ src/lib/lib9290/CMakeLists.txt | 155 ++++++++++++ src/lib/lib9290/Makefile | 211 ++++++++++++---- src/lib/libdvd90/BUILDCONF.sh | 14 ++ src/lib/libdvd90/CMakeLists.txt | 19 ++ src/lib/libdvd90/Makefile | 60 ++--- src/lib/libdvd90/Makefile_Ser | 35 --- src/lib/libdvd90/Makefile_mpi | 36 --- src/lib/libmcp90/BUILDCONF.sh | 8 + src/lib/libmcp90/CMakeLists.txt | 9 + src/lib/libmcp90/Makefile | 44 ++-- src/lib/libmod/BUILDCONF.sh | 108 ++++++++ src/lib/libmod/CMakeLists.txt | 109 ++++++++ src/lib/libmod/Makefile | 190 ++++++++------ src/lib/librang90/BUILDCONF.sh | 95 +++++++ src/lib/librang90/CMakeLists.txt | 183 ++++++++++++++ src/lib/librang90/Makefile | 249 ++++++++++++++----- src/lib/mpi90/BUILDCONF.sh | 20 ++ src/lib/mpi90/CMakeLists.txt | 35 +++ src/lib/mpi90/Makefile | 82 +++--- src/tool/BUILDCONF.sh | 76 ++++++ src/tool/CMakeLists.txt | 91 +++++++ src/tool/Makefile | 158 +++++------- test/CMakeLists.txt | 14 ++ test/lib9290_quad.f90 | 54 ++++ 96 files changed, 5860 insertions(+), 1219 deletions(-) create mode 100644 .github/workflows/buildfiles.yml create mode 100644 .github/workflows/buildmake.yml create mode 100644 .github/workflows/test.yml create mode 100644 CMakeLists.txt create mode 100755 configure.sh create mode 100755 contrib/checkbin.sh create mode 100755 contrib/genbuild.sh create mode 100755 contrib/genbuildall.sh create mode 100644 src/appl/HF/BUILDCONF.sh create mode 100644 src/appl/HF/CMakeLists.txt create mode 100644 src/appl/jj2lsj90/BUILDCONF.sh create mode 100644 src/appl/jj2lsj90/CMakeLists.txt create mode 100644 src/appl/jjgen90/BUILDCONF.sh create mode 100644 src/appl/jjgen90/CMakeLists.txt create mode 100644 src/appl/rangular90/BUILDCONF.sh create mode 100644 src/appl/rangular90/CMakeLists.txt create mode 100644 src/appl/rangular90_mpi/BUILDCONF.sh create mode 100644 src/appl/rangular90_mpi/CMakeLists.txt create mode 100644 src/appl/rbiotransform90/BUILDCONF.sh create mode 100644 src/appl/rbiotransform90/CMakeLists.txt create mode 100644 src/appl/rbiotransform90_mpi/BUILDCONF.sh create mode 100644 src/appl/rbiotransform90_mpi/CMakeLists.txt create mode 100644 src/appl/rci90/BUILDCONF.sh create mode 100644 src/appl/rci90/CMakeLists.txt create mode 100644 src/appl/rci90_mpi/BUILDCONF.sh create mode 100644 src/appl/rci90_mpi/CMakeLists.txt create mode 100644 src/appl/rcsfgenerate90/BUILDCONF.sh create mode 100644 src/appl/rcsfgenerate90/CMakeLists.txt create mode 100644 src/appl/rcsfinteract90/BUILDCONF.sh create mode 100644 src/appl/rcsfinteract90/CMakeLists.txt create mode 100644 src/appl/rcsfzerofirst90/BUILDCONF.sh create mode 100644 src/appl/rcsfzerofirst90/CMakeLists.txt create mode 100644 src/appl/rhfs90/BUILDCONF.sh create mode 100644 src/appl/rhfs90/CMakeLists.txt create mode 100644 src/appl/rmcdhf90/BUILDCONF.sh create mode 100644 src/appl/rmcdhf90/CMakeLists.txt create mode 100644 src/appl/rmcdhf90_mpi/BUILDCONF.sh create mode 100644 src/appl/rmcdhf90_mpi/CMakeLists.txt create mode 100644 src/appl/rnucleus90/BUILDCONF.sh create mode 100644 src/appl/rnucleus90/CMakeLists.txt create mode 100644 src/appl/rtransition90/BUILDCONF.sh create mode 100644 src/appl/rtransition90/CMakeLists.txt create mode 100644 src/appl/rtransition90_mpi/BUILDCONF.sh create mode 100644 src/appl/rtransition90_mpi/CMakeLists.txt create mode 100644 src/appl/rwfnestimate90/BUILDCONF.sh create mode 100644 src/appl/rwfnestimate90/CMakeLists.txt create mode 100644 src/appl/sms90/BUILDCONF.sh create mode 100644 src/appl/sms90/CMakeLists.txt create mode 100644 src/lib/lib9290/BUILDCONF.sh create mode 100644 src/lib/lib9290/CMakeLists.txt create mode 100644 src/lib/libdvd90/BUILDCONF.sh create mode 100644 src/lib/libdvd90/CMakeLists.txt delete mode 100644 src/lib/libdvd90/Makefile_Ser delete mode 100644 src/lib/libdvd90/Makefile_mpi create mode 100644 src/lib/libmcp90/BUILDCONF.sh create mode 100644 src/lib/libmcp90/CMakeLists.txt create mode 100644 src/lib/libmod/BUILDCONF.sh create mode 100644 src/lib/libmod/CMakeLists.txt create mode 100644 src/lib/librang90/BUILDCONF.sh create mode 100644 src/lib/librang90/CMakeLists.txt create mode 100644 src/lib/mpi90/BUILDCONF.sh create mode 100644 src/lib/mpi90/CMakeLists.txt create mode 100644 src/tool/BUILDCONF.sh create mode 100644 src/tool/CMakeLists.txt create mode 100644 test/CMakeLists.txt create mode 100644 test/lib9290_quad.f90 diff --git a/.github/workflows/buildfiles.yml b/.github/workflows/buildfiles.yml new file mode 100644 index 000000000..ad0658e62 --- /dev/null +++ b/.github/workflows/buildfiles.yml @@ -0,0 +1,13 @@ +name: Verify build files + +on: [push, pull_request] + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: Verify CMake/Make files + run: ./contrib/genbuildall.sh --verify diff --git a/.github/workflows/buildmake.yml b/.github/workflows/buildmake.yml new file mode 100644 index 000000000..7da7d76f4 --- /dev/null +++ b/.github/workflows/buildmake.yml @@ -0,0 +1,19 @@ +name: Build with Make + +on: [push, pull_request] + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: "Install dependencies" + run: sudo apt-get install -y build-essential gfortran liblapack-dev libblas-dev openmpi-bin openmpi-common libopenmpi-dev + - name: Build GRASP + run: | + source make_environment_gfortran + cd src/ && make + - name: Verify binaries + run: ./contrib/checkbin.sh diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 000000000..71ca1f35b --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,23 @@ +name: Tests + +on: [push, pull_request] + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: "Install dependencies" + run: sudo apt-get install -y build-essential gfortran liblapack-dev libblas-dev openmpi-bin openmpi-common libopenmpi-dev cmake + - name: Build GRASP + run: | + ./configure.sh + cd build/ + make + make install + - name: Verify binaries + run: ./contrib/checkbin.sh + - name: Run test suite + run: cd build/ && ctest diff --git a/.gitignore b/.gitignore index 015657697..5123c8abf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,16 @@ -*.out -*.err +# Ignore artifacts from Make builds *.o *.mod -lib/* -bin/* +/bin/* +!/bin/.gitkeep +/lib/* +!/lib/.gitkeep + +# Ignore generated CMake files +build/ +build-*/ +CMakeLists.user + +# Ignore output log files +*.out +*.err diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 000000000..3bf7a1689 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,182 @@ +# To build the CMake-based bits you first need to set up the build directory +# (out of tree builds are preferred). For that run: +# +# mkdir build/ && cd build/ && cmake .. +# +# And then under the build/ directory simply call +# +# make +# +# which will compile and install all the libraries to lib/ +# + +cmake_minimum_required(VERSION 2.6) +project(grasp) + +enable_language(Fortran) +enable_testing() + +# "Release" will be the default build type, which gives us optimization flags etc. +# The other relevant option would be "Debug", which disables optimizations and +# enables debugging symbols. The debug build can be enabled when setting up the +# build directory with CMake: +# +# cmake -DCMAKE_BUILD_TYPE=Debug .. +# +if(NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE "Release" CACHE STRING + "Choose the type of build, options are: Release Debug." + FORCE + ) +endif(NOT CMAKE_BUILD_TYPE) + +# Find the LAPACK and BLAS libraries +find_package(BLAS REQUIRED) +find_package(LAPACK REQUIRED) + +# We need special functions to handle linking Fortran modules between libraries +# etc. The Fortran_MODULE_DIRECTORY_root variable is the directory where all the +# .mod files get written to. It is set be the modules/ subdirectory of the build +# directory. +# +# For every library, the modules get stored in +# ${Fortran_MODULE_DIRECTORY_root}// so the modules from different +# libraries are separated from each other. +# +# +# Command: setup_fortran_modules(target) +# +# Needs to be called on all libraries that provide modules. It set the +# Fortran_MODULE_DIRECTORY variable for the target, which is then used by +# target_link_libraries_Fortran to set up the appropriate include directories. +# +# Example: +# +# setup_fortran_modules(9290) +# +# +# Command: target_link_libraries_Fortran(target mode libraries...) +# +# Similar to target_link_libraries(), but will also set up paths so that the +# compiler could fine the the Fortran .mod files from of the libraries. Unlike +# for the standard command, mode ( = PUBLIC, PRIVATE) is mandatory. +# +# Modified version of: https://stackoverflow.com/a/43918277/1601695 +# +# Example: +# +# target_link_libraries_Fortran(rcsfsplit PRIVATE mod 9290) +# +set(Fortran_MODULE_DIRECTORY_root ${CMAKE_CURRENT_BINARY_DIR}/modules) +function(setup_fortran_modules target) + set_property(TARGET ${target} PROPERTY Fortran_MODULE_DIRECTORY "${Fortran_MODULE_DIRECTORY_root}/${target}") + install(DIRECTORY "${Fortran_MODULE_DIRECTORY_root}/${target}" DESTINATION "${CMAKE_INSTALL_PREFIX}/lib/" + FILES_MATCHING PATTERN "*.mod") +endfunction() +function(target_link_libraries_Fortran target mode) + target_link_libraries(${target} ${mode} ${ARGN}) + foreach(lib IN LISTS ARGN) + target_include_directories(${target} ${mode} $) + endforeach() +endfunction() + + +# We put the compiled binaries into the bin/ subdirectory of the build directory +# and libraries into the lib/ subdirectory. +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/bin/") +set(CMAKE_LIBRARY_OUTPUT_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/lib/") +set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/lib/") +# To install the binaries into the standard /bin/ directory, you need to +# call `make install`. +set(CMAKE_INSTALL_PREFIX ${PROJECT_SOURCE_DIR}) + +# Additional Fortran compiler flags. +# +# -fno-automatic: this was set in the original make_environment_gfortran_UBC file. +# +# Note: optimization should be enabled on the Release target automatically. +# +# If need be, you can also set up linker flags. E.g.: +# +# set(CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} -static-libgfortran") +# +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fno-automatic") + +message("Compiler flags etc. for this GRASP build:") +message("* CMAKE_BUILD_TYPE: ${CMAKE_BUILD_TYPE}") +message("* CMAKE_Fortran_COMPILER: ${CMAKE_Fortran_COMPILER}") +message("* CMAKE_Fortran_COMPILER_VERSION: ${CMAKE_Fortran_COMPILER_VERSION}") +message("* CMAKE_Fortran_FLAGS: ${CMAKE_Fortran_FLAGS}") +message("* CMAKE_Fortran_FLAGS_RELEASE: ${CMAKE_Fortran_FLAGS_RELEASE}") +message("* CMAKE_Fortran_FLAGS_DEBUG: ${CMAKE_Fortran_FLAGS_DEBUG}") +message("* CMAKE_EXE_LINKER_FLAGS: ${CMAKE_EXE_LINKER_FLAGS}") +message("* CMAKE_STATIC_LINKER_FLAGS: ${CMAKE_STATIC_LINKER_FLAGS}") +message("* CMAKE_RUNTIME_OUTPUT_DIRECTORY: ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}") +message("* CMAKE_LIBRARY_OUTPUT_DIRECTORY: ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}") +message("* CMAKE_ARCHIVE_OUTPUT_DIRECTORY: ${CMAKE_ARCHIVE_OUTPUT_DIRECTORY}") +message("* BLAS_LIBRARIES: ${BLAS_LIBRARIES}") +message("* BLAS_LINKER_FLAGS: ${BLAS_LINKER_FLAGS}") +message("* LAPACK_LIBRARIES: ${LAPACK_LIBRARIES}") +message("* LAPACK_LINKER_FLAGS: ${LAPACK_LINKER_FLAGS}") + +# GRASP libraries +add_subdirectory("src/lib/libmod") +add_subdirectory("src/lib/lib9290") +add_subdirectory("src/lib/libdvd90") +add_subdirectory("src/lib/libmcp90") +add_subdirectory("src/lib/librang90") + +# GRASP application programs +add_subdirectory("src/appl/HF") +add_subdirectory("src/appl/jj2lsj90") +add_subdirectory("src/appl/jjgen90") +add_subdirectory("src/appl/rangular90") +add_subdirectory("src/appl/rbiotransform90") +add_subdirectory("src/appl/rci90") +add_subdirectory("src/appl/rcsfgenerate90") +add_subdirectory("src/appl/rcsfinteract90") +add_subdirectory("src/appl/rcsfzerofirst90") +add_subdirectory("src/appl/rhfs90") +add_subdirectory("src/appl/rmcdhf90") +add_subdirectory("src/appl/rnucleus90") +add_subdirectory("src/appl/rtransition90") +add_subdirectory("src/appl/rwfnestimate90") +add_subdirectory("src/appl/sms90") + +# Additional GRASP tools and programs +add_subdirectory("src/tool") + +# We only build MPI programs and libraries if we can actually find MPI on +# the user's system. +find_package(MPI) +if(MPI_Fortran_FOUND) + message("* MPI_Fortran_LIBRARIES: ${MPI_Fortran_LIBRARIES}") + message("* MPI_Fortran_INCLUDE_PATH: ${MPI_Fortran_INCLUDE_PATH}") + message("* MPI_Fortran_COMPILE_FLAGS: ${MPI_Fortran_COMPILE_FLAGS}") + message("* MPI_Fortran_LINK_FLAGS: ${MPI_Fortran_LINK_FLAGS}") + + add_subdirectory("src/lib/mpi90") + add_subdirectory("src/appl/rangular90_mpi") + add_subdirectory("src/appl/rbiotransform90_mpi") + add_subdirectory("src/appl/rci90_mpi") + add_subdirectory("src/appl/rmcdhf90_mpi") + add_subdirectory("src/appl/rtransition90_mpi") +else() + message("MPI libraries not found. Not building MPI-dependent programs.") +endif(MPI_Fortran_FOUND) + +# Unit and integration tests +add_subdirectory("test") + +# We use the CMakeLists.txt so that the user could easily add additional targets +# to the GRASP build, such as additional (external) GRASP programs that need to +# be linked agains the GRASP libraries. +# +# We also set the GRASP variable that the user-defined targets can use to figure +# out where the root of the GRASP source tree is. +set(GRASP ${PROJECT_SOURCE_DIR}) +unset(GRASP_CMakeLists_user CACHE) +find_file(GRASP_CMakeLists_user "CMakeLists.user" ${PROJECT_SOURCE_DIR}) +if(NOT "${GRASP_CMakeLists_user}" STREQUAL "GRASP_CMakeLists_user-NOTFOUND") + include(${GRASP_CMakeLists_user}) +endif() diff --git a/README.md b/README.md index 65cf4cd25..c8c32973f 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,95 @@ # General Relativistic Atomic Structure Package -**GRASP2018 - an F95 development version** - [![][manual-badge]][manual-pdf] +The General Relativistic Atomic Structure Package (GRASP) is a set of Fortran 90 +programs for performing fully-relativistic electron structure calculations of +atoms. + +## Installation + +> **Please note:** +> The installation instructions here are for the _development version_ on the +> `master` branch. +> +> To install the _latest published release_ (2018-12-03), go to the +> ["Releases" page](https://github.com/compas/grasp/releases/tag/2018-12-03), +> download the tarball from there and refer to the instructions in the README in +> the tarball. + +To compile and install GRASP, first clone this Git repository: + +```sh +git clone https://github.com/compas/grasp.git +``` + +There are two ways to build GRASP: either via [CMake](https://cmake.org/) or via the +`Makefile`s in the source tree. Either works and you end up with the GRASP binaries in the +`bin/` directory. + +CMake is the recommended way to build GRASP. The `Makefile`-based workflow is still there to +make smoother to transition from `Makefile`s to a modern build system. + +### CMake-based build + +The first step with CMake is to create a separate out-of-source build directory. The +`configure.sh` script can do that for you: + +```sh +cd grasp/ && ./configure.sh +``` + +This will create a `build/` directory with the default _Release_ build +configuration. However, `configure.sh` is just a simple wrapper around a `cmake` +call and if you need more control over the build, you can always invoke `cmake` +yourself (see [CMake documentation](https://cmake.org/documentation/) for more +information). + +To then compile GRASP, you need to go into the out-of-source build directory and +simply call `make`: + +```sh +cd build/ && make install +``` + +Remarks: + +* Running `make install` instructs CMake to actually _install_ the resulting binaries into + the conventional `bin/` directory at the root of the repository. + + When you run just `make`, the resulting binaries will end up under the `build/` directory + (specifically in `build/bin/`). This is useful when developing and debugging, as it allows + you to compile many versions of the binaries from the same source tree with different + compilation options (e.g. build with debug symbols enabled) by using several out of source + build directories. + +* With CMake, GRASP also supports parallel builds, which can be enabled by passing the `-j` + option to `make` (e.g. `make -j4 install` to build with four processes). + +* The CMake-based build allows running the (non-comprehensive) test suite by calling `ctest` + in the `build/` directory. The configuration and source files for the tests are under + `test/`/ + +### `Makefile`-based build + +The legacy `Makefile`-based build can be performed by first loading the necessary +environment variables (which may have to be modified to suit your system). E.g.: + +```sh +source make_environment_gfortran +``` + +To actually build the binaries, you have to call `make` on the root `Makefile` in `src/`: + +``` +cd src/ && make +``` + +**WARNING:** the `Makefile`s do not know about the dependencies between the source files, so +parallel builds (i.e. calling `make` with the `-j` option) does not work. + +## About GRASP + This version of GRASP is a major revision of the previous GRASP2K package by [P. Jonsson, G. Gaigalas, J. Bieron, C. Froese Fischer, and I.P. Grant Computer Physics Communication, 184, 2197 - 2203 (2013)][grasp2k-2013] written in FORTRAN diff --git a/configure.sh b/configure.sh new file mode 100755 index 000000000..c5241f5f0 --- /dev/null +++ b/configure.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +export GRASP="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" + +build_directory="build" # we default to build/ + +cmake_args="" +for arg in $@; do + if [ "$arg" == "--debug" ]; then + echo "Creating a DEBUG build" + build_directory="build-debug" + cmake_args="-DCMAKE_BUILD_TYPE=Debug" + fi +done + +# We create an empty CMakeLists.user file, so that the user would not have to +# re-create it later. +touch "${GRASP}/CMakeLists.user" || exit + +# Determine and check the build directory +build_abspath="${GRASP}/${build_directory}" +echo "Build directory: ${build_abspath}" +if [ -e "${build_abspath}" ]; then + >&2 echo "ERROR: Build directory already exists." + exit 1 +fi + +# We run the default setup for CMake's out-of-tree builds +# +# mkdir build/ +# cd build/ +# cmake .. +# +mkdir "${build_abspath}" && cd "${build_abspath}" \ + && cmake ${cmake_args} "${GRASP}" \ + || exit + +# Note: we need to use spaces, not tabs, to indent in the heredoc. +cat <<-EOF +Build directory ${build_directory}/ created. +To build GRASP run you need to cd into ${build_directory}/ and run make: + + cd ${build_directory}/ + make + +Note that you probably want to also enable parallel builds by pass -j to make: + + make -jN + +where N is the number of cores you have available. +EOF diff --git a/contrib/checkbin.sh b/contrib/checkbin.sh new file mode 100755 index 000000000..f4a6664f9 --- /dev/null +++ b/contrib/checkbin.sh @@ -0,0 +1,86 @@ +#!/usr/bin/env bash +export DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" + +BINARIES=" +hf +jj2lsj +jjgen +lscomp.pl +rangular +rangular_mpi +rasfsplit +rbiotransform rbiotransform_mpi +rci rci_mpi +rcsfblock +rcsfgenerate +rcsfinteract +rcsfmr +rcsfsplit +rcsfzerofirst +rhfs +rhfs_lsj +rlevels +rlevelseV +rmcdhf rmcdhf_mpi +rmixaccumulate +rmixextract +rnucleus +rsave +rseqenergy +rseqhfs +rseqtrans +rsms +rtabhfs +rtablevels +rtabtrans1 rtabtrans2 rtabtransE1 +rtransition rtransition_mpi +rwfnestimate +rwfnmchfmcdf +rwfnplot +rwfnrelabel +rwfnrotate +wfnplot +" + +LIBRARIES=" +9290 +dvd90 +mcp90 +mod +mpiu90 +rang90 +" + +success=true + +BIN="${DIR}/../bin" +for p in ${BINARIES}; do + if ! [ -f "${BIN}/$p" ]; then + >&2 echo "ERROR: binary ${p} missing from bin/" + success=false + fi +done + +LIB="${DIR}/../lib" +for lib in ${LIBRARIES}; do + if ! [ -f "${LIB}/lib${lib}.a" ]; then + >&2 echo "ERROR: library lib${lib}.a missing from lib/" + success=false + fi + if ! [ -d "${LIB}/$lib" ]; then + >&2 echo "ERROR: modules directory for ${lib} missing in lib/" + success=false + fi +done + +if [ "$success" = "false" ]; then + >&2 echo "FAIL: Verification failed, check the logs." + >&2 echo "INFO: ls -Alh bin/" + ls -Alh "${BIN}" + >&2 echo "INFO: ls -Alh lib/" + ls -Alh "${LIB}" + exit 1 +else + >&2 echo "SUCCESS: Found all the binaries in all the right places." + exit 0 +fi diff --git a/contrib/genbuild.sh b/contrib/genbuild.sh new file mode 100755 index 000000000..5eeb89dce --- /dev/null +++ b/contrib/genbuild.sh @@ -0,0 +1,260 @@ +#!/usr/bin/env bash +# +# Variables that affect the behaviour: +# +# - EXE & LIB: only one should be set, name of the target +# - FILES: List of .f90 source files, in the correct order (if there are between the files) +# - LIBRARIES: List of libraries that this library or binary depends on +# +# External dependencies: +# - LAPACK: Attach LAPACK and BLAS libraries +# - ISMPI: Attach MPI libraries +# +function generate-makefile { + >&2 echo "Generating a Makefile" + if ! [ -z ${EXE+x} ]; then + _generate-makefile-binary + elif ! [ -z ${LIB+x} ]; then + _generate-makefile-library + else + >&2 echo "ERROR: neither EXE nor LIB specified" + exit 1 + fi +} + +function _generate-makefile-binary { + cat <<-EOF + EXE=\${GRASP}/bin/${EXE} + EOF + + if ! [ -z ${ISMPI+x} ]; then + FC="FC_MPI" + FC_FLAGS="\$(FC_MPIFLAGS)" + FC_LDFLAGS="\$(FC_MPILD)" + else + FC="FC" + FC_FLAGS="\$(FC_FLAGS)" + FC_LDFLAGS="\$(FC_LD)" + fi + + if ! [ -z ${LIBRARIES+x} ]; then + # TODO: trim space at the end of the string + makelibs_string=$(for lib in ${LIBRARIES}; do echo -n " -l${lib}"; done) + echo "LIBS=-L \${GRASP}/lib/${makelibs_string}" + FC_LDFLAGS="${FC_LDFLAGS} \$(LIBS)" + moddirs=$(for lib in ${LIBRARIES}; do echo -n " -I \${GRASP}/src/lib/$(libdir $lib)"; done) + echo "FC_MODULES=${moddirs}" + FC_FLAGS="${FC_FLAGS} \$(FC_MODULES)" + fi + + if ! [ -z ${LAPACK} ]; then + FC_LDFLAGS="${FC_LDFLAGS} \$(LAPACK_LIBS)" + fi + + echo + echo -n "OBJS=" + for file in $(echo "$FILES" | sed 's/#.*$//'); do + if [[ "$file" =~ ^(.+)\.f90$ ]]; then + echo " \\" + echo -n " ${BASH_REMATCH[1]}.o" + else + >&2 echo "ERROR: Invalid file in FILES: $file" + exit 1 + fi + done + echo; echo + + cat <<-EOF | sed 's/ /\t/' + \$(EXE): \$(OBJS) + \$($FC) -o \$@ \$? ${FC_LDFLAGS} + + %.o: %.f90 + \$($FC) -c ${FC_FLAGS} -o \$@ \$< + + clean: + -@rm \$(EXE) + -@rm *.o *.mod + EOF +} + +function _generate-makefile-library { + cat <<-EOF + LIBA=\${GRASP}/lib/lib${LIB}.a + MODULES_INSTALL=\${GRASP}/lib/${LIB} + EOF + + if ! [ -z ${ISMPI+x} ]; then + FC="FC_MPI" + FC_FLAGS="\$(FC_MPIFLAGS)" + else + FC="FC" + FC_FLAGS="\$(FC_FLAGS)" + fi + + if ! [ -z ${LIBRARIES+x} ]; then + moddirs=$(for lib in ${LIBRARIES}; do echo -n " -I \${GRASP}/src/lib/$(libdir $lib)"; done) + echo "FC_MODULES=${moddirs}" + FC_FLAGS="${FC_FLAGS} \$(FC_MODULES)" + fi + + echo + echo -n "OBJS=" + for file in $(echo "$FILES" | sed 's/#.*$//'); do + if [[ "$file" =~ ^(.+)\.f90$ ]]; then + echo " \\" + echo -n " ${BASH_REMATCH[1]}.o" + else + >&2 echo "ERROR: Invalid file in FILES: $file" + exit 1 + fi + done + echo; echo + + cat <<-EOF | sed 's/ /\t/' + PHONY: install + install: \$(LIBA) + mkdir -p \$(MODULES_INSTALL) + cp -v *.mod \$(MODULES_INSTALL) + + \$(LIBA): \$(OBJS) + @echo "Installing \$@" + ar -curs \$@ \$? + + %.o: %.f90 + \$($FC) -c ${FC_FLAGS} -o \$@ \$< + + clean: + -@rm \$(LIBA) + -@rm *.o *.mod + -@rm -R \$(MODULES_INSTALL) + EOF +} + +function libdir { + if [ "$1" = "mod" ]; then + echo "libmod" + elif [ "$1" = "9290" ]; then + echo "lib9290" + elif [ "$1" = "mpiu90" ]; then + echo "mpi90" + else + echo "lib${1}" + fi +} + +function generate-cmakelists { + >&2 echo "Generating CMakeLists.txt" + if ! [ -z ${EXE+x} ]; then + TARGET=$EXE + echo "add_executable(${EXE}" + elif ! [ -z ${LIB+x} ]; then + TARGET=$LIB + echo "add_library(${LIB} STATIC" + else + >&2 echo "ERROR: neither EXE nor LIB specified" + exit 1 + fi + for file in $(echo "$FILES" | sed 's/#.*$//'); do + echo " ${file}" + done + echo ")" + if ! [ -z ${LIB+x} ]; then + echo "setup_fortran_modules($LIB)" + fi + if ! [ -z ${LIBRARIES+x} ]; then + if ! [ -z ${EXE+x} ]; then + echo "target_link_libraries_Fortran(${TARGET} PUBLIC ${LIBRARIES})" + else + echo "target_link_libraries_Fortran(${TARGET} PRIVATE ${LIBRARIES})" + fi + fi + # Add LAPACK and BLAS libraries to libraries + if [ -z ${EXE+x} ]; then + if ! [ -z ${LAPACK} ]; then + echo "target_link_libraries(${TARGET} PRIVATE \${BLAS_LIBRARIES} \${BLAS_LINKER_FLAGS})" + echo "target_link_libraries(${TARGET} PRIVATE \${LAPACK_LIBRARIES} \${LAPACK_LINKER_FLAGS})" + fi + if ! [ -z ${ISMPI+x} ]; then + cat <<-EOF + target_include_directories(${TARGET} PRIVATE \${MPI_Fortran_INCLUDE_PATH}) + target_link_libraries(${TARGET} PRIVATE \${MPI_Fortran_LIBRARIES}) + set_target_properties(${TARGET} PROPERTIES + COMPILE_FLAGS "\${MPI_Fortran_COMPILE_FLAGS}" + LINK_FLAGS "\${MPI_Fortran_LINK_FLAGS}" + ) + EOF + fi + fi + if ! [ -z ${EXE+x} ]; then + echo "install(TARGETS ${EXE} DESTINATION bin/)" + else + echo "install(TARGETS ${LIB} DESTINATION lib/)" + fi +} + +# The main script: +CMAKELISTSTXT=CMakeLists.txt +MAKEFILE=Makefile +for arg in $@; do + if [ "$arg" = "--verify" ]; then + VERIFY=true + CMAKELISTSTXT=`tempfile` + MAKEFILE=`tempfile` + shift + elif [[ $arg =~ ^- ]]; then + >&2 echo "ERROR: Invalid argument $@" + exit 1 + else + break + fi +done +if [ "$#" -ne 1 ]; then + >&2 echo "ERROR: Must provide a single argument (target directory)" + exit 1 +fi +# Construct the path to the target directory, relative to $PWD if not an absolute path +if [[ "$1" =~ ^/(.+) ]]; then + target=$1 +else + target="${PWD}/$1" +fi + +if ! [ -d "${target}" ]; then + >&2 echo "ERROR: Invalid directory ${target}" + exit 1 +fi + +if ! [ -f "${target}/BUILDCONF.sh" ]; then + >&2 echo "ERROR: Missing BUILDCONF.sh file in ${target}" + exit 1 +fi + +if ! output=$(cd ${target} || exit; source "${target}/BUILDCONF.sh" 2>&1); then + >&2 echo "ERROR: BUILDCONF.sh script failed for $target" + echo "Output:" + echo "$output" + exit 2 +else + echo "BUILDCONF.sh ran successfully in $target" + echo "Output:" + echo "$output" + + if ! [ -z ${VERIFY+x} ]; then + >&2 echo "INFO: Running in verification mode" + >&2 echo " CMakeLists.txt = ${CMAKELISTSTXT}" + >&2 echo " Makefile = ${MAKEFILE}" + + diff ${CMAKELISTSTXT} "${target}/CMakeLists.txt" || { + >&2 echo "ERROR: CMakeLists.txt differs" + VERIFY=fail + } + diff ${MAKEFILE} "${target}/Makefile" + + rm -v "${CMAKELISTSTXT}" "${MAKEFILE}" + + if [ "$VERIFY" = "fail" ]; then + exit 3 + fi + fi + exit 0 +fi diff --git a/contrib/genbuildall.sh b/contrib/genbuildall.sh new file mode 100755 index 000000000..1526e96f1 --- /dev/null +++ b/contrib/genbuildall.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +export DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +GENBUILD="${DIR}/genbuild.sh" +SRCDIR="${DIR}/../src" +if ! [ -f "${GENBUILD}" ]; then >&2 echo "ERROR: Unable to find genbuild.sh at ${GENBUILD}"; exit 1; fi +if ! [ -d "${SRCDIR}" ]; then >&2 echo "ERROR: Not a directory: ${SRCDIR}"; exit 1; fi +if ! [ -d "${SRCDIR}/appl" ]; then >&2 echo "ERROR: Not a directory: ${SRCDIR}/appl"; exit 1; fi +if ! [ -d "${SRCDIR}/lib" ]; then >&2 echo "ERROR: Not a directory: ${SRCDIR}/lib"; exit 1; fi +if ! [ -d "${SRCDIR}/tool" ]; then >&2 echo "ERROR: Not a directory: ${SRCDIR}/tool"; exit 1; fi + +directories=" + $(find ${SRCDIR}/appl/ -mindepth 1 -maxdepth 1 -type d) + $(find ${SRCDIR}/lib/ -mindepth 1 -maxdepth 1 -type d) + ${SRCDIR}/tool +" +success=true +for d in ${directories}; do + if ! [ -f "${d}/BUILDCONF.sh" ]; then + >&2 echo "> WARNING: BUILDCONF.sh missing in $(basename $d)" + >&2 echo "> in $d" + continue + fi + echo "> Calling genbuild.sh $@ for $(basename $d)" + if ! output=$($GENBUILD $@ "$d" 2>&1); then + success=false + >&2 echo "> WARNING: genbuild.sh failed with $? for $(basename $d)" + >&2 echo "> in $d" + >&2 echo "Output:" + >&2 echo "$output" + fi +done +if [ $success = false ]; then + >&2 echo "> ERROR: genbuildall.sh failed" + exit 1 +fi diff --git a/src/Makefile b/src/Makefile index 85215d314..e661a05d9 100644 --- a/src/Makefile +++ b/src/Makefile @@ -12,7 +12,7 @@ $(TARGETS): do \ cd $$i ; \ echo "....Entering: $$i" ; \ - $(MAKE) $@ ; \ + $(MAKE); \ cd .. ; \ echo "....Leaving: $$i" ; echo; echo;\ done diff --git a/src/appl/HF/BUILDCONF.sh b/src/appl/HF/BUILDCONF.sh new file mode 100644 index 000000000..5881d86eb --- /dev/null +++ b/src/appl/HF/BUILDCONF.sh @@ -0,0 +1,4 @@ +EXE=hf +FILES="HF.f90" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/HF/CMakeLists.txt b/src/appl/HF/CMakeLists.txt new file mode 100644 index 000000000..e0ed9d039 --- /dev/null +++ b/src/appl/HF/CMakeLists.txt @@ -0,0 +1,4 @@ +add_executable(hf + HF.f90 +) +install(TARGETS hf DESTINATION bin/) diff --git a/src/appl/HF/Makefile b/src/appl/HF/Makefile index a472b7523..3caec6b88 100644 --- a/src/appl/HF/Makefile +++ b/src/appl/HF/Makefile @@ -1,20 +1,14 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/hf -BIN = ${GRASP}/bin +OBJS= \ + HF.o -UTIL = hf +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) -install: EXE - -EXE : $(BIN)/hf - -OBJ : hf .o - -$(BIN)/hf: HF.o - $(FC) -o $(BIN)/hf HF.o - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/jj2lsj90/BUILDCONF.sh b/src/appl/jj2lsj90/BUILDCONF.sh new file mode 100644 index 000000000..bf0f181c3 --- /dev/null +++ b/src/appl/jj2lsj90/BUILDCONF.sh @@ -0,0 +1,13 @@ +EXE=jj2lsj +LIBRARIES="9290 rang90 mod " +FILES=" +getmixblock.f90 getmixblock_I.f90 +idigit.f90 idigit_I.f90 +lval.f90 lval_I.f90 +packLS.f90 packLS_I.f90 +jj2lsj_data_1_C.f90 jj2lsj_data_2_C.f90 jj2lsj_data_3_C.f90 +jj2lsj_code.f90 +jj2lsj2K.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/jj2lsj90/CMakeLists.txt b/src/appl/jj2lsj90/CMakeLists.txt new file mode 100644 index 000000000..c825aa8ed --- /dev/null +++ b/src/appl/jj2lsj90/CMakeLists.txt @@ -0,0 +1,17 @@ +add_executable(jj2lsj + getmixblock.f90 + getmixblock_I.f90 + idigit.f90 + idigit_I.f90 + lval.f90 + lval_I.f90 + packLS.f90 + packLS_I.f90 + jj2lsj_data_1_C.f90 + jj2lsj_data_2_C.f90 + jj2lsj_data_3_C.f90 + jj2lsj_code.f90 + jj2lsj2K.f90 +) +target_link_libraries_Fortran(jj2lsj PUBLIC 9290 rang90 mod ) +install(TARGETS jj2lsj DESTINATION bin/) diff --git a/src/appl/jj2lsj90/Makefile b/src/appl/jj2lsj90/Makefile index fc464ef04..45e993fd4 100644 --- a/src/appl/jj2lsj90/Makefile +++ b/src/appl/jj2lsj90/Makefile @@ -1,48 +1,28 @@ -.SUFFIXES: .f90 .mod - -# executable :: jj2lsj90 -EXE = jj2lsj -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG = ${SRCLIBDIR}/librang90 -GRASPLIBS = -l9290 -lrang90 -lmod - -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -# Define Commons -Commons = jj2lsj_data_1_C.o jj2lsj_data_2_C.o jj2lsj_data_3_C.o - -# Define memory management module -Memory = ${MODDIR}/memory_man.o - -# Define interface to routines from the library -Interface = packLS_I.o getmixblock_I.o idigit_I.o lval_I.o - -APP_OBJ = \ - packLS.o getmixblock.o idigit.o lval.o \ - jj2lsj_code.o jj2lsj2K.o - -$(EXE): ${VASTO} ${Commons} ${Memory} ${Interface} $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(Commons) ${Interface} $(APP_OBJ) $(APP_LIBS) - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} \ - -I ${MODLRANG} -o $@ - -.f90.mod: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} \ - -I ${MODLRANG} -o $@ +EXE=${GRASP}/bin/jj2lsj +LIBS=-L ${GRASP}/lib/ -l9290 -lrang90 -lmod +FC_MODULES= -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmod + +OBJS= \ + getmixblock.o \ + getmixblock_I.o \ + idigit.o \ + idigit_I.o \ + lval.o \ + lval_I.o \ + packLS.o \ + packLS_I.o \ + jj2lsj_data_1_C.o \ + jj2lsj_data_2_C.o \ + jj2lsj_data_3_C.o \ + jj2lsj_code.o \ + jj2lsj2K.o + +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) + +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod - -APP_SRC = \ - jj2lsj_data_1.f90 jj2lsj_data_2.f90 jj2lsj_data_3.f90 \ - jj2lsj_code.f90 jj2lsj2K.f90 + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/jjgen90/BUILDCONF.sh b/src/appl/jjgen90/BUILDCONF.sh new file mode 100644 index 000000000..26260a477 --- /dev/null +++ b/src/appl/jjgen90/BUILDCONF.sh @@ -0,0 +1,43 @@ +EXE=jjgen +LIBRARIES="mod 9290 rang90" +FILES=" +lockad.f90 lockad_I.f90 +reada.f90 reada_I.f90 +lasa1.f90 lasa1_I.f90 +lasa2.f90 lasa2_I.f90 +adder.f90 adder_I.f90 +slug.f90 slug_I.f90 +kopp1.f90 kopp1_I.f90 +kopp2.f90 kopp2_I.f90 + +# gen.f90 was not compiled in the Makefile, but genb.f90 was. genb.f90 +# contains the implementation for GEN. +genb.f90 gen_I.f90 + +sluggo.f90 sluggo_I.f90 +test.f90 test_I.f90 +mergeb.f90 mergeb_I.f90 +blanda.f90 blanda_I.f90 +blandb.f90 blandb_I.f90 +blandc.f90 blandc_I.f90 +copy7t9.f90 copy7t9_I.f90 +fivefirst.f90 fivefirst_I.f90 +fivelines.f90 fivelines_I.f90 +lika.f90 lika_I.f90 +matain.f90 matain_I.f90 +matbin.f90 matbin_I.f90 +matcin.f90 matcin_I.f90 +merge.f90 merge_I.f90 +open79.f90 open79_I.f90 +reffa.f90 reffa_I.f90 + +# There is also jjgen15.f90, but that was not being compiled in the original +# makefile. +jjgen15b.f90 + +# There are two more files that were not compiled in the original makefile +#lasax-reada.f90 +#m.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/jjgen90/CMakeLists.txt b/src/appl/jjgen90/CMakeLists.txt new file mode 100644 index 000000000..32f7d88df --- /dev/null +++ b/src/appl/jjgen90/CMakeLists.txt @@ -0,0 +1,55 @@ +add_executable(jjgen + lockad.f90 + lockad_I.f90 + reada.f90 + reada_I.f90 + lasa1.f90 + lasa1_I.f90 + lasa2.f90 + lasa2_I.f90 + adder.f90 + adder_I.f90 + slug.f90 + slug_I.f90 + kopp1.f90 + kopp1_I.f90 + kopp2.f90 + kopp2_I.f90 + genb.f90 + gen_I.f90 + sluggo.f90 + sluggo_I.f90 + test.f90 + test_I.f90 + mergeb.f90 + mergeb_I.f90 + blanda.f90 + blanda_I.f90 + blandb.f90 + blandb_I.f90 + blandc.f90 + blandc_I.f90 + copy7t9.f90 + copy7t9_I.f90 + fivefirst.f90 + fivefirst_I.f90 + fivelines.f90 + fivelines_I.f90 + lika.f90 + lika_I.f90 + matain.f90 + matain_I.f90 + matbin.f90 + matbin_I.f90 + matcin.f90 + matcin_I.f90 + merge.f90 + merge_I.f90 + open79.f90 + open79_I.f90 + reffa.f90 + reffa_I.f90 + jjgen15b.f90 +) +target_link_libraries_Fortran(jjgen PUBLIC mod 9290 rang90) +install(TARGETS jjgen DESTINATION bin/) diff --git a/src/appl/jjgen90/Makefile b/src/appl/jjgen90/Makefile index 3fa70d5bd..96480b965 100644 --- a/src/appl/jjgen90/Makefile +++ b/src/appl/jjgen90/Makefile @@ -1,34 +1,66 @@ -# JJGEN Program +EXE=${GRASP}/bin/jjgen +LIBS=-L ${GRASP}/lib/ -lmod -l9290 -lrang90 +FC_MODULES= -I ${GRASP}/src/lib/libmod -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/librang90 -.SUFFIXES: .f90 .mod +OBJS= \ + lockad.o \ + lockad_I.o \ + reada.o \ + reada_I.o \ + lasa1.o \ + lasa1_I.o \ + lasa2.o \ + lasa2_I.o \ + adder.o \ + adder_I.o \ + slug.o \ + slug_I.o \ + kopp1.o \ + kopp1_I.o \ + kopp2.o \ + kopp2_I.o \ + genb.o \ + gen_I.o \ + sluggo.o \ + sluggo_I.o \ + test.o \ + test_I.o \ + mergeb.o \ + mergeb_I.o \ + blanda.o \ + blanda_I.o \ + blandb.o \ + blandb_I.o \ + blandc.o \ + blandc_I.o \ + copy7t9.o \ + copy7t9_I.o \ + fivefirst.o \ + fivefirst_I.o \ + fivelines.o \ + fivelines_I.o \ + lika.o \ + lika_I.o \ + matain.o \ + matain_I.o \ + matbin.o \ + matbin_I.o \ + matcin.o \ + matcin_I.o \ + merge.o \ + merge_I.o \ + open79.o \ + open79_I.o \ + reffa.o \ + reffa_I.o \ + jjgen15b.o -EXE = jjgen -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -GRASPLIBS =-l9290 -lrang90 -lmod +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) - -MOD_OBJ= adder_I.o blanda_I.o blandb_I.o blandc_I.o copy7t9_I.o fivefirst_I.o \ - fivelines_I.o gen_I.o kopp1_I.o kopp2_I.o lasa1_I.o lasa2_I.o \ - lika_I.o lockad_I.o matain_I.o matbin_I.o matcin_I.o mergeb_I.o \ - merge_I.o open79_I.o reada_I.o reffa_I.o sluggo_I.o slug_I.o test_I.o - - -APP_OBJ= adder.o blanda.o blandc.o blandb.o fivefirst.o fivelines.o \ - genb.o jjgen15b.o kopp1.o kopp2.o lasa1.o lasa2.o lika.o \ - lockad.o matain.o matcin.o matbin.o merge.o mergeb.o \ - reada.o reffa.o slug.o sluggo.o test.o copy7t9.o open79.o - -$(EXE): $(MOD_OBJ) $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) - -.f90.o: - $(FC) -c $< -I . -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rangular90/BUILDCONF.sh b/src/appl/rangular90/BUILDCONF.sh new file mode 100644 index 000000000..2a4afb465 --- /dev/null +++ b/src/appl/rangular90/BUILDCONF.sh @@ -0,0 +1,26 @@ +EXE=rangular +LIBRARIES="rang90 mcp90 9290 mod" +LAPACK=true +FILES=" +allocCheck.f90 allocCheck_I.f90 +fndbeg.f90 fndbeg_I.f90 +getinf.f90 getinf_I.f90 +sort.f90 sort_I.f90 +sortmem.f90 sortmem_I.f90 +outsda.f90 outsda_I.f90 +setsda.f90 setsda_I.f90 +mcp_gg.f90 mcp_gg_I.f90 +setdbg.f90 setdbg_I.f90 +setmcp.f90 setmcp_I.f90 +setmcp2.f90 setmcp2_I.f90 +setsum.f90 setsum_I.f90 +settmpGG.f90 settmpGG_I.f90 +strsum.f90 strsum_I.f90 + +genmcp.f90 + +# cons_C was not being compiled in the original makefile +#cons_C.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rangular90/CMakeLists.txt b/src/appl/rangular90/CMakeLists.txt new file mode 100644 index 000000000..65684d5c8 --- /dev/null +++ b/src/appl/rangular90/CMakeLists.txt @@ -0,0 +1,33 @@ +add_executable(rangular + allocCheck.f90 + allocCheck_I.f90 + fndbeg.f90 + fndbeg_I.f90 + getinf.f90 + getinf_I.f90 + sort.f90 + sort_I.f90 + sortmem.f90 + sortmem_I.f90 + outsda.f90 + outsda_I.f90 + setsda.f90 + setsda_I.f90 + mcp_gg.f90 + mcp_gg_I.f90 + setdbg.f90 + setdbg_I.f90 + setmcp.f90 + setmcp_I.f90 + setmcp2.f90 + setmcp2_I.f90 + setsum.f90 + setsum_I.f90 + settmpGG.f90 + settmpGG_I.f90 + strsum.f90 + strsum_I.f90 + genmcp.f90 +) +target_link_libraries_Fortran(rangular PUBLIC rang90 mcp90 9290 mod) +install(TARGETS rangular DESTINATION bin/) diff --git a/src/appl/rangular90/Makefile b/src/appl/rangular90/Makefile index a60695b7c..25c81fca4 100644 --- a/src/appl/rangular90/Makefile +++ b/src/appl/rangular90/Makefile @@ -1,41 +1,44 @@ -.SUFFIXES: .f90 .mod - -EXE = rangular -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS = -l9290 -lrang90 -l9290 -lmcp90 -lmod - -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - - -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - fndbeg_I.o mcp_gg_I.o setmcp_I.o settmpGG_I.o \ - setdbg_I.o outsda_I.o setsda_I.o sort_I.o \ - getinf_I.o setmcp2_I.o setsum_I.o strsum_I.o \ - allocCheck_I.o sortmem_I.o \ - \ - genmcp.o mcp_gg.o outsda.o setmcp2.o \ - fndbeg.o getinf.o setdbg.o setmcp.o setsda.o setsum.o settmpGG.o \ - sort.o strsum.o allocCheck.o sortmem.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) $(LAPACK_LIBS) - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I ${MODDIR} -I $(MODL9290) -I $(MODLRANG90) -I $(MODLMCP90) -I ${MODDIR} -o $@ - - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +EXE=${GRASP}/bin/rangular +LIBS=-L ${GRASP}/lib/ -lrang90 -lmcp90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod + +OBJS= \ + allocCheck.o \ + allocCheck_I.o \ + fndbeg.o \ + fndbeg_I.o \ + getinf.o \ + getinf_I.o \ + sort.o \ + sort_I.o \ + sortmem.o \ + sortmem_I.o \ + outsda.o \ + outsda_I.o \ + setsda.o \ + setsda_I.o \ + mcp_gg.o \ + mcp_gg_I.o \ + setdbg.o \ + setdbg_I.o \ + setmcp.o \ + setmcp_I.o \ + setmcp2.o \ + setmcp2_I.o \ + setsum.o \ + setsum_I.o \ + settmpGG.o \ + settmpGG_I.o \ + strsum.o \ + strsum_I.o \ + genmcp.o + +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) + +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rangular90_mpi/BUILDCONF.sh b/src/appl/rangular90_mpi/BUILDCONF.sh new file mode 100644 index 000000000..02f0b26f4 --- /dev/null +++ b/src/appl/rangular90_mpi/BUILDCONF.sh @@ -0,0 +1,22 @@ +EXE=rangular_mpi +LIBRARIES="rang90 mcp90 mpiu90 9290 mod" +LAPACK=true +ISMPI=true +FILES=" +fndbeg.f90 fndbeg_I.f90 +getinf.f90 getinf_I.f90 +outsdampi.f90 outsdampi_I.f90 +setdbg.f90 setdbg_I.f90 +setdbgmpi.f90 setdbgmpi_I.f90 +setmcp.f90 setmcp_I.f90 +setmcpmpi.f90 setmcpmpi_I.f90 +setsda.f90 setsda_I.f90 +setsum.f90 setsum_I.f90 +settmp.f90 settmp_I.f90 +sort.f90 sort_I.f90 +strsum.f90 strsum_I.f90 +mcpmpi_gg.f90 mcpmpi_gg_I.f90 +genmcpmpi.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rangular90_mpi/CMakeLists.txt b/src/appl/rangular90_mpi/CMakeLists.txt new file mode 100644 index 000000000..71b16ca62 --- /dev/null +++ b/src/appl/rangular90_mpi/CMakeLists.txt @@ -0,0 +1,31 @@ +add_executable(rangular_mpi + fndbeg.f90 + fndbeg_I.f90 + getinf.f90 + getinf_I.f90 + outsdampi.f90 + outsdampi_I.f90 + setdbg.f90 + setdbg_I.f90 + setdbgmpi.f90 + setdbgmpi_I.f90 + setmcp.f90 + setmcp_I.f90 + setmcpmpi.f90 + setmcpmpi_I.f90 + setsda.f90 + setsda_I.f90 + setsum.f90 + setsum_I.f90 + settmp.f90 + settmp_I.f90 + sort.f90 + sort_I.f90 + strsum.f90 + strsum_I.f90 + mcpmpi_gg.f90 + mcpmpi_gg_I.f90 + genmcpmpi.f90 +) +target_link_libraries_Fortran(rangular_mpi PUBLIC rang90 mcp90 mpiu90 9290 mod) +install(TARGETS rangular_mpi DESTINATION bin/) diff --git a/src/appl/rangular90_mpi/Makefile b/src/appl/rangular90_mpi/Makefile index f46126d6e..22f79b85f 100644 --- a/src/appl/rangular90_mpi/Makefile +++ b/src/appl/rangular90_mpi/Makefile @@ -1,44 +1,42 @@ -.SUFFIXES: .f90 .mod - -EXE = rangular_mpi -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 -GRASPLIBS = -l9290 -lrang90 -l9290 -lmpiu90 -lmcp90 -l9290 -lmod - -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - - -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - fndbeg_I.o mcpmpi_gg_I.o outsdampi_I.o setmcpmpi_I.o setmcp_I.o settmp_I.o \ - setdbgmpi_I.o setsda_I.o sort_I.o \ - setdbg_I.o \ - getinf_I.o setsum_I.o strsum_I.o \ -\ - genmcpmpi.o mcpmpi_gg.o outsdampi.o setmcpmpi.o \ - fndbeg.o getinf.o setdbgmpi.o setmcp.o setsda.o setsum.o settmp.o \ +EXE=${GRASP}/bin/rangular_mpi +LIBS=-L ${GRASP}/lib/ -lrang90 -lmcp90 -lmpiu90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/mpi90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod + +OBJS= \ + fndbeg.o \ + fndbeg_I.o \ + getinf.o \ + getinf_I.o \ + outsdampi.o \ + outsdampi_I.o \ setdbg.o \ - sort.o strsum.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - ${LAPACK_LIBS} - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I $(MODL9290) -I $(MODLRANG90) -I $(MODLMCP90) -I ${MODDIR} -I $(MODLMPIU90) -o $@ - - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ + setdbg_I.o \ + setdbgmpi.o \ + setdbgmpi_I.o \ + setmcp.o \ + setmcp_I.o \ + setmcpmpi.o \ + setmcpmpi_I.o \ + setsda.o \ + setsda_I.o \ + setsum.o \ + setsum_I.o \ + settmp.o \ + settmp_I.o \ + sort.o \ + sort_I.o \ + strsum.o \ + strsum_I.o \ + mcpmpi_gg.o \ + mcpmpi_gg_I.o \ + genmcpmpi.o + +$(EXE): $(OBJS) + $(FC_MPI) -o $@ $? $(FC_MPILD) $(LIBS) $(LAPACK_LIBS) + +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rbiotransform90/BUILDCONF.sh b/src/appl/rbiotransform90/BUILDCONF.sh new file mode 100644 index 000000000..15c1f7bbc --- /dev/null +++ b/src/appl/rbiotransform90/BUILDCONF.sh @@ -0,0 +1,54 @@ +EXE=rbiotransform +LIBRARIES="rang90 9290 mod" +LAPACK=true +FILES=" +angdata.f90 angdata_I.f90 +bndinv.f90 bndinv_I.f90 +brkt.f90 brkt_I.f90 +wrtmat.f90 wrtmat_I.f90 +scalve.f90 scalve_I.f90 +copvec.f90 copvec_I.f90 +fname.f90 fname_I.f90 +getmix.f90 getmix_I.f90 +gets.f90 gets_I.f90 +ielsum.f90 ielsum_I.f90 +ifnmnx.f90 ifnmnx_I.f90 +rintff.f90 rintff_I.f90 +rintii.f90 rintii_I.f90 +inprod.f90 inprod_I.f90 +intrpqf.f90 intrpqf_I.f90 +intrpqi.f90 intrpqi_I.f90 +invmat.f90 invmat_I.f90 +kapdata.f90 kapdata_I.f90 +lodcslBio.f90 lodcslBio_I.f90 +lodrwff.f90 lodrwff_I.f90 +lodrwfi.f90 lodrwfi_I.f90 +prsym.f90 prsym_I.f90 +lulu.f90 lulu_I.f90 +setvec.f90 setvec_I.f90 +matml4.f90 matml4_I.f90 +qqsort.f90 qqsort_I.f90 +mcpin.f90 mcpin_I.f90 +mcpout_gg.f90 mcpout_gg_I.f90 +pamtmt.f90 pamtmt_I.f90 +radfile.f90 radfile_I.f90 +radpar.f90 radpar_I.f90 +setcslb.f90 setcslb_I.f90 +tcsl.f90 tcsl_I.f90 +ti1tv.f90 ti1tv_I.f90 +tiinig.f90 tiinig_I.f90 +trpmat.f90 trpmat_I.f90 +ulla.f90 ulla_I.f90 +vecsum.f90 vecsum_I.f90 +genmcp.f90 genmcp_I.f90 +citrag.f90 citrag_I.f90 +biotr1.f90 biotr1_I.f90 +biotr.f90 + +# The _implementations_ for these routines were not being compiled in the +# original makefile. The interface files were still linked though. +#ichkq1.f90 ichkq1_I.f90 +#orbord.f90 orbord_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rbiotransform90/CMakeLists.txt b/src/appl/rbiotransform90/CMakeLists.txt new file mode 100644 index 000000000..dd6012229 --- /dev/null +++ b/src/appl/rbiotransform90/CMakeLists.txt @@ -0,0 +1,87 @@ +add_executable(rbiotransform + angdata.f90 + angdata_I.f90 + bndinv.f90 + bndinv_I.f90 + brkt.f90 + brkt_I.f90 + wrtmat.f90 + wrtmat_I.f90 + scalve.f90 + scalve_I.f90 + copvec.f90 + copvec_I.f90 + fname.f90 + fname_I.f90 + getmix.f90 + getmix_I.f90 + gets.f90 + gets_I.f90 + ielsum.f90 + ielsum_I.f90 + ifnmnx.f90 + ifnmnx_I.f90 + rintff.f90 + rintff_I.f90 + rintii.f90 + rintii_I.f90 + inprod.f90 + inprod_I.f90 + intrpqf.f90 + intrpqf_I.f90 + intrpqi.f90 + intrpqi_I.f90 + invmat.f90 + invmat_I.f90 + kapdata.f90 + kapdata_I.f90 + lodcslBio.f90 + lodcslBio_I.f90 + lodrwff.f90 + lodrwff_I.f90 + lodrwfi.f90 + lodrwfi_I.f90 + prsym.f90 + prsym_I.f90 + lulu.f90 + lulu_I.f90 + setvec.f90 + setvec_I.f90 + matml4.f90 + matml4_I.f90 + qqsort.f90 + qqsort_I.f90 + mcpin.f90 + mcpin_I.f90 + mcpout_gg.f90 + mcpout_gg_I.f90 + pamtmt.f90 + pamtmt_I.f90 + radfile.f90 + radfile_I.f90 + radpar.f90 + radpar_I.f90 + setcslb.f90 + setcslb_I.f90 + tcsl.f90 + tcsl_I.f90 + ti1tv.f90 + ti1tv_I.f90 + tiinig.f90 + tiinig_I.f90 + trpmat.f90 + trpmat_I.f90 + ulla.f90 + ulla_I.f90 + vecsum.f90 + vecsum_I.f90 + genmcp.f90 + genmcp_I.f90 + citrag.f90 + citrag_I.f90 + biotr1.f90 + biotr1_I.f90 + biotr.f90 +) +target_link_libraries_Fortran(rbiotransform PUBLIC rang90 9290 mod) +install(TARGETS rbiotransform DESTINATION bin/) diff --git a/src/appl/rbiotransform90/Makefile b/src/appl/rbiotransform90/Makefile index ee9bd295a..3192f7c62 100644 --- a/src/appl/rbiotransform90/Makefile +++ b/src/appl/rbiotransform90/Makefile @@ -1,44 +1,98 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rbiotransform +LIBS=-L ${GRASP}/lib/ -lrang90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rbiotransform -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 +OBJS= \ + angdata.o \ + angdata_I.o \ + bndinv.o \ + bndinv_I.o \ + brkt.o \ + brkt_I.o \ + wrtmat.o \ + wrtmat_I.o \ + scalve.o \ + scalve_I.o \ + copvec.o \ + copvec_I.o \ + fname.o \ + fname_I.o \ + getmix.o \ + getmix_I.o \ + gets.o \ + gets_I.o \ + ielsum.o \ + ielsum_I.o \ + ifnmnx.o \ + ifnmnx_I.o \ + rintff.o \ + rintff_I.o \ + rintii.o \ + rintii_I.o \ + inprod.o \ + inprod_I.o \ + intrpqf.o \ + intrpqf_I.o \ + intrpqi.o \ + intrpqi_I.o \ + invmat.o \ + invmat_I.o \ + kapdata.o \ + kapdata_I.o \ + lodcslBio.o \ + lodcslBio_I.o \ + lodrwff.o \ + lodrwff_I.o \ + lodrwfi.o \ + lodrwfi_I.o \ + prsym.o \ + prsym_I.o \ + lulu.o \ + lulu_I.o \ + setvec.o \ + setvec_I.o \ + matml4.o \ + matml4_I.o \ + qqsort.o \ + qqsort_I.o \ + mcpin.o \ + mcpin_I.o \ + mcpout_gg.o \ + mcpout_gg_I.o \ + pamtmt.o \ + pamtmt_I.o \ + radfile.o \ + radfile_I.o \ + radpar.o \ + radpar_I.o \ + setcslb.o \ + setcslb_I.o \ + tcsl.o \ + tcsl_I.o \ + ti1tv.o \ + ti1tv_I.o \ + tiinig.o \ + tiinig_I.o \ + trpmat.o \ + trpmat_I.o \ + ulla.o \ + ulla_I.o \ + vecsum.o \ + vecsum_I.o \ + genmcp.o \ + genmcp_I.o \ + citrag.o \ + citrag_I.o \ + biotr1.o \ + biotr1_I.o \ + biotr.o -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -APP_OBJ= \ - angdata_I.o getmix_I.o invmat_I.o pamtmt_I.o setcslb_I.o \ - biotr1_I.o gets_I.o kapdata_I.o prsym_I.o setvec_I.o \ - bndinv_I.o ichkq1_I.o lodrwff_I.o qqsort_I.o tcsl_I.o \ - brkt_I.o ielsum_I.o lodrwfi_I.o radfile_I.o tiinig_I.o \ - citrag_I.o ifnmnx_I.o lulu_I.o radpar_I.o trpmat_I.o \ - copvec_I.o inprod_I.o matml4_I.o rintff_I.o ulla_I.o \ - fname_I.o intrpqf_I.o mcpout_gg_I.o rintii_I.o vecsum_I.o \ - genmcp_I.o intrpqi_I.o orbord_I.o scalve_I.o wrtmat_I.o \ - mcpin_I.o ti1tv_I.o lodcslBio_I.o \ - biotr.o fname.o intrpqf.o intrpqi.o kapdata.o lodrwff.o lodrwfi.o \ - radpar.o rintff.o rintii.o tcsl.o brkt.o gets.o wrtmat.o \ - biotr1.o radfile.o ifnmnx.o ielsum.o copvec.o invmat.o \ - ulla.o trpmat.o matml4.o scalve.o setvec.o pamtmt.o bndinv.o lulu.o \ - inprod.o genmcp.o mcpin.o getmix.o qqsort.o citrag.o tiinig.o \ - ti1tv.o vecsum.o prsym.o setcslb.o angdata.o mcpout_gg.o lodcslBio.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rbiotransform90_mpi/BUILDCONF.sh b/src/appl/rbiotransform90_mpi/BUILDCONF.sh new file mode 100644 index 000000000..d5455140d --- /dev/null +++ b/src/appl/rbiotransform90_mpi/BUILDCONF.sh @@ -0,0 +1,55 @@ +EXE=rbiotransform_mpi +LIBRARIES="rang90 mpiu90 9290 mod" +LAPACK=true +ISMPI=true +FILES=" +angdatampi.f90 angdatampi_I.f90 +bndinv.f90 bndinv_I.f90 +brkt.f90 brkt_I.f90 +vecsum.f90 vecsum_I.f90 +wrtmat.f90 wrtmat_I.f90 +copvec.f90 copvec_I.f90 +fname.f90 fname_I.f90 +getmixmpi.f90 getmixmpi_I.f90 +getsmpi.f90 getsmpi_I.f90 +ielsum.f90 ielsum_I.f90 +ifnmnx.f90 ifnmnx_I.f90 +inprod.f90 inprod_I.f90 +invmat.f90 invmat_I.f90 +rintff.f90 rintff_I.f90 +rintii.f90 rintii_I.f90 +intrpqf.f90 intrpqf_I.f90 +intrpqi.f90 intrpqi_I.f90 +kapdata.f90 kapdata_I.f90 +lodcslBio.f90 lodcslBio_I.f90 +lodrwffmpi.f90 lodrwffmpi_I.f90 +lodrwfimpi.f90 lodrwfimpi_I.f90 +prsym.f90 prsym_I.f90 +lulu.f90 lulu_I.f90 +setvec.f90 setvec_I.f90 +matml4.f90 matml4_I.f90 +qqsortmpi.f90 qqsortmpi_I.f90 +mcpinmpi.f90 mcpinmpi_I.f90 +mcpoutmpi_gg.f90 mcpoutmpi_gg_I.f90 +pamtmt.f90 pamtmt_I.f90 +radfilempi.f90 radfilempi_I.f90 +radparmpi.f90 radparmpi_I.f90 +scalve.f90 scalve_I.f90 +setcslampi.f90 setcslampi_I.f90 +setcslbmpi.f90 setcslbmpi_I.f90 +tcsl.f90 tcsl_I.f90 +ti1tv.f90 ti1tv_I.f90 +tiinigmpi.f90 tiinigmpi_I.f90 +trpmat.f90 trpmat_I.f90 +ulla.f90 ulla_I.f90 +citragmpi.f90 citragmpi_I.f90 +biotr1.f90 biotr1_I.f90 +biotrmpi.f90 + +# These routines were not being compiled in the original makefile. The +# interface file for ORBORD this was still linked though. +#orbord.f90 orbord_I.f90 +#tiinig.f90 tiinig_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rbiotransform90_mpi/CMakeLists.txt b/src/appl/rbiotransform90_mpi/CMakeLists.txt new file mode 100644 index 000000000..859c9f7f4 --- /dev/null +++ b/src/appl/rbiotransform90_mpi/CMakeLists.txt @@ -0,0 +1,87 @@ +add_executable(rbiotransform_mpi + angdatampi.f90 + angdatampi_I.f90 + bndinv.f90 + bndinv_I.f90 + brkt.f90 + brkt_I.f90 + vecsum.f90 + vecsum_I.f90 + wrtmat.f90 + wrtmat_I.f90 + copvec.f90 + copvec_I.f90 + fname.f90 + fname_I.f90 + getmixmpi.f90 + getmixmpi_I.f90 + getsmpi.f90 + getsmpi_I.f90 + ielsum.f90 + ielsum_I.f90 + ifnmnx.f90 + ifnmnx_I.f90 + inprod.f90 + inprod_I.f90 + invmat.f90 + invmat_I.f90 + rintff.f90 + rintff_I.f90 + rintii.f90 + rintii_I.f90 + intrpqf.f90 + intrpqf_I.f90 + intrpqi.f90 + intrpqi_I.f90 + kapdata.f90 + kapdata_I.f90 + lodcslBio.f90 + lodcslBio_I.f90 + lodrwffmpi.f90 + lodrwffmpi_I.f90 + lodrwfimpi.f90 + lodrwfimpi_I.f90 + prsym.f90 + prsym_I.f90 + lulu.f90 + lulu_I.f90 + setvec.f90 + setvec_I.f90 + matml4.f90 + matml4_I.f90 + qqsortmpi.f90 + qqsortmpi_I.f90 + mcpinmpi.f90 + mcpinmpi_I.f90 + mcpoutmpi_gg.f90 + mcpoutmpi_gg_I.f90 + pamtmt.f90 + pamtmt_I.f90 + radfilempi.f90 + radfilempi_I.f90 + radparmpi.f90 + radparmpi_I.f90 + scalve.f90 + scalve_I.f90 + setcslampi.f90 + setcslampi_I.f90 + setcslbmpi.f90 + setcslbmpi_I.f90 + tcsl.f90 + tcsl_I.f90 + ti1tv.f90 + ti1tv_I.f90 + tiinigmpi.f90 + tiinigmpi_I.f90 + trpmat.f90 + trpmat_I.f90 + ulla.f90 + ulla_I.f90 + citragmpi.f90 + citragmpi_I.f90 + biotr1.f90 + biotr1_I.f90 + biotrmpi.f90 +) +target_link_libraries_Fortran(rbiotransform_mpi PUBLIC rang90 mpiu90 9290 mod) +install(TARGETS rbiotransform_mpi DESTINATION bin/) diff --git a/src/appl/rbiotransform90_mpi/Makefile b/src/appl/rbiotransform90_mpi/Makefile index 77a5bc24e..6e170830d 100644 --- a/src/appl/rbiotransform90_mpi/Makefile +++ b/src/appl/rbiotransform90_mpi/Makefile @@ -1,46 +1,98 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rbiotransform_mpi +LIBS=-L ${GRASP}/lib/ -lrang90 -lmpiu90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/mpi90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rbiotransform_mpi -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 +OBJS= \ + angdatampi.o \ + angdatampi_I.o \ + bndinv.o \ + bndinv_I.o \ + brkt.o \ + brkt_I.o \ + vecsum.o \ + vecsum_I.o \ + wrtmat.o \ + wrtmat_I.o \ + copvec.o \ + copvec_I.o \ + fname.o \ + fname_I.o \ + getmixmpi.o \ + getmixmpi_I.o \ + getsmpi.o \ + getsmpi_I.o \ + ielsum.o \ + ielsum_I.o \ + ifnmnx.o \ + ifnmnx_I.o \ + inprod.o \ + inprod_I.o \ + invmat.o \ + invmat_I.o \ + rintff.o \ + rintff_I.o \ + rintii.o \ + rintii_I.o \ + intrpqf.o \ + intrpqf_I.o \ + intrpqi.o \ + intrpqi_I.o \ + kapdata.o \ + kapdata_I.o \ + lodcslBio.o \ + lodcslBio_I.o \ + lodrwffmpi.o \ + lodrwffmpi_I.o \ + lodrwfimpi.o \ + lodrwfimpi_I.o \ + prsym.o \ + prsym_I.o \ + lulu.o \ + lulu_I.o \ + setvec.o \ + setvec_I.o \ + matml4.o \ + matml4_I.o \ + qqsortmpi.o \ + qqsortmpi_I.o \ + mcpinmpi.o \ + mcpinmpi_I.o \ + mcpoutmpi_gg.o \ + mcpoutmpi_gg_I.o \ + pamtmt.o \ + pamtmt_I.o \ + radfilempi.o \ + radfilempi_I.o \ + radparmpi.o \ + radparmpi_I.o \ + scalve.o \ + scalve_I.o \ + setcslampi.o \ + setcslampi_I.o \ + setcslbmpi.o \ + setcslbmpi_I.o \ + tcsl.o \ + tcsl_I.o \ + ti1tv.o \ + ti1tv_I.o \ + tiinigmpi.o \ + tiinigmpi_I.o \ + trpmat.o \ + trpmat_I.o \ + ulla.o \ + ulla_I.o \ + citragmpi.o \ + citragmpi_I.o \ + biotr1.o \ + biotr1_I.o \ + biotrmpi.o -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 -lmpiu90 +$(EXE): $(OBJS) + $(FC_MPI) -o $@ $? $(FC_MPILD) $(LIBS) $(LAPACK_LIBS) -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} - -APP_OBJ= \ - angdatampi_I.o getmixmpi_I.o invmat_I.o pamtmt_I.o setcslbmpi_I.o \ - setcslampi_I.o biotr1_I.o getsmpi_I.o kapdata_I.o prsym_I.o setvec_I.o \ - bndinv_I.o lodrwffmpi_I.o qqsortmpi_I.o tcsl_I.o \ - brkt_I.o ielsum_I.o lodrwfimpi_I.o radfilempi_I.o tiinigmpi_I.o \ - citragmpi_I.o ifnmnx_I.o lulu_I.o radparmpi_I.o trpmat_I.o \ - copvec_I.o inprod_I.o matml4_I.o rintff_I.o ulla_I.o \ - fname_I.o intrpqf_I.o mcpoutmpi_gg_I.o rintii_I.o vecsum_I.o \ - intrpqi_I.o orbord_I.o scalve_I.o wrtmat_I.o \ - mcpinmpi_I.o ti1tv_I.o lodcslBio_I.o \ - biotrmpi.o fname.o intrpqf.o intrpqi.o kapdata.o lodrwffmpi.o lodrwfimpi.o \ - radparmpi.o rintff.o rintii.o tcsl.o brkt.o getsmpi.o wrtmat.o \ - biotr1.o radfilempi.o ifnmnx.o ielsum.o copvec.o invmat.o \ - ulla.o trpmat.o matml4.o scalve.o setvec.o pamtmt.o bndinv.o lulu.o \ - inprod.o mcpinmpi.o getmixmpi.o qqsortmpi.o citragmpi.o tiinigmpi.o \ - ti1tv.o vecsum.o prsym.o setcslampi.o setcslbmpi.o angdatampi.o mcpoutmpi_gg.o lodcslBio.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) $(LAPACK_LIBS) - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -I $(MODLMPIU90) -o $@ - -.f.o: - $(FC_MPI) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rci90/BUILDCONF.sh b/src/appl/rci90/BUILDCONF.sh new file mode 100644 index 000000000..9a83efaab --- /dev/null +++ b/src/appl/rci90/BUILDCONF.sh @@ -0,0 +1,93 @@ +EXE=rci +LIBRARIES="rang90 9290 dvd90 mod" +LAPACK=true +FILES=" +# Missing interface +evcout.f90 + +# For these routines, only the interface files were linked in the original +# makefile. +#dspevx.f90 dspevx_I.f90 +#ratden.f90 ratden_I.f90 +dspevx_I.f90 +ratden_I.f90 + +# Missing implementation, but linked in the original makefile +#dmerge_dnicmv_I.f90 + +# Missing implementation and not referenced in the original makefile +#inter_I.f90 + +# Not referenced in the original makefile +#setham_to_genmat2_C.f90 +#t.f90 + +talk.f90 talk_I.f90 +cxk.f90 cxk_I.f90 +bessel.f90 bessel_I.f90 +dnicmv.f90 dnicmv_I.f90 +engout.f90 engout_I.f90 +funk.f90 funk_I.f90 +funl.f90 funl_I.f90 +mohr.f90 mohr_I.f90 +klamaq.f90 klamaq_I.f90 +fzalf.f90 fzalf_I.f90 +breid.f90 breid_I.f90 +zkf.f90 zkf_I.f90 +rkint.f90 rkint_I.f90 +rkintc.f90 rkintc_I.f90 +skint.f90 skint_I.f90 +brra.f90 brra_I.f90 +brintf.f90 brintf_I.f90 +brint1.f90 brint1_I.f90 +brint2.f90 brint2_I.f90 +brint3.f90 brint3_I.f90 +brint4.f90 brint4_I.f90 +brint5.f90 brint5_I.f90 +brint6.f90 brint6_I.f90 +triangbreit1.f90 triangbreit1_I.f90 +triangbreit2.f90 triangbreit2_I.f90 +genintbreit1.f90 genintbreit1_I.f90 +genintbreit2.f90 genintbreit2_I.f90 +genintrk.f90 genintrk_I.f90 +getcid.f90 getcid_I.f90 +hmout.f90 hmout_I.f90 +hovlap.f90 hovlap_I.f90 +iabint.f90 iabint_I.f90 +indtpi.f90 indtpi_I.f90 +iniestdm.f90 iniestdm_I.f90 +iniestsd.f90 iniestsd_I.f90 +keint.f90 keint_I.f90 +lodmix.f90 lodmix_I.f90 +lodres.f90 lodres_I.f90 +spodmv.f90 spodmv_I.f90 +maneig.f90 maneig_I.f90 +ncharg.f90 ncharg_I.f90 +qed.f90 qed_I.f90 +qed_slfen.f90 qed_slfen_I.f90 +setcsl.f90 setcsl_I.f90 +setdbg.f90 setdbg_I.f90 +setmix.f90 setmix_I.f90 +setres.f90 setres_I.f90 +setsum.f90 setsum_I.f90 +shield.f90 shield_I.f90 +strsum.f90 strsum_I.f90 +triangrk.f90 triangrk_I.f90 +vac2.f90 vac2_I.f90 +vac4.f90 vac4_I.f90 +vacpol.f90 vacpol_I.f90 +vinti.f90 vinti_I.f90 +vint.f90 vint_I.f90 +vpintf.f90 vpintf_I.f90 +vpint.f90 vpint_I.f90 +wghtd5.f90 wghtd5_I.f90 +setham_gg.f90 setham_gg_I.f90 +genmat.f90 genmat_I.f90 +genmat2.f90 genmat2_I.f90 +auxblk.f90 auxblk_I.f90 +matrix.f90 matrix_I.f90 + +rci92.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rci90/CMakeLists.txt b/src/appl/rci90/CMakeLists.txt new file mode 100644 index 000000000..a3e5d032e --- /dev/null +++ b/src/appl/rci90/CMakeLists.txt @@ -0,0 +1,136 @@ +add_executable(rci + evcout.f90 + dspevx_I.f90 + ratden_I.f90 + talk.f90 + talk_I.f90 + cxk.f90 + cxk_I.f90 + bessel.f90 + bessel_I.f90 + dnicmv.f90 + dnicmv_I.f90 + engout.f90 + engout_I.f90 + funk.f90 + funk_I.f90 + funl.f90 + funl_I.f90 + mohr.f90 + mohr_I.f90 + klamaq.f90 + klamaq_I.f90 + fzalf.f90 + fzalf_I.f90 + breid.f90 + breid_I.f90 + zkf.f90 + zkf_I.f90 + rkint.f90 + rkint_I.f90 + rkintc.f90 + rkintc_I.f90 + skint.f90 + skint_I.f90 + brra.f90 + brra_I.f90 + brintf.f90 + brintf_I.f90 + brint1.f90 + brint1_I.f90 + brint2.f90 + brint2_I.f90 + brint3.f90 + brint3_I.f90 + brint4.f90 + brint4_I.f90 + brint5.f90 + brint5_I.f90 + brint6.f90 + brint6_I.f90 + triangbreit1.f90 + triangbreit1_I.f90 + triangbreit2.f90 + triangbreit2_I.f90 + genintbreit1.f90 + genintbreit1_I.f90 + genintbreit2.f90 + genintbreit2_I.f90 + genintrk.f90 + genintrk_I.f90 + getcid.f90 + getcid_I.f90 + hmout.f90 + hmout_I.f90 + hovlap.f90 + hovlap_I.f90 + iabint.f90 + iabint_I.f90 + indtpi.f90 + indtpi_I.f90 + iniestdm.f90 + iniestdm_I.f90 + iniestsd.f90 + iniestsd_I.f90 + keint.f90 + keint_I.f90 + lodmix.f90 + lodmix_I.f90 + lodres.f90 + lodres_I.f90 + spodmv.f90 + spodmv_I.f90 + maneig.f90 + maneig_I.f90 + ncharg.f90 + ncharg_I.f90 + qed.f90 + qed_I.f90 + qed_slfen.f90 + qed_slfen_I.f90 + setcsl.f90 + setcsl_I.f90 + setdbg.f90 + setdbg_I.f90 + setmix.f90 + setmix_I.f90 + setres.f90 + setres_I.f90 + setsum.f90 + setsum_I.f90 + shield.f90 + shield_I.f90 + strsum.f90 + strsum_I.f90 + triangrk.f90 + triangrk_I.f90 + vac2.f90 + vac2_I.f90 + vac4.f90 + vac4_I.f90 + vacpol.f90 + vacpol_I.f90 + vinti.f90 + vinti_I.f90 + vint.f90 + vint_I.f90 + vpintf.f90 + vpintf_I.f90 + vpint.f90 + vpint_I.f90 + wghtd5.f90 + wghtd5_I.f90 + setham_gg.f90 + setham_gg_I.f90 + genmat.f90 + genmat_I.f90 + genmat2.f90 + genmat2_I.f90 + auxblk.f90 + auxblk_I.f90 + matrix.f90 + matrix_I.f90 + rci92.f90 +) +target_link_libraries_Fortran(rci PUBLIC rang90 9290 dvd90 mod) +install(TARGETS rci DESTINATION bin/) diff --git a/src/appl/rci90/Makefile b/src/appl/rci90/Makefile index 1ad902261..3fae00a5e 100644 --- a/src/appl/rci90/Makefile +++ b/src/appl/rci90/Makefile @@ -1,59 +1,147 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rci +LIBS=-L ${GRASP}/lib/ -lrang90 -l9290 -ldvd90 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/libmod -EXE = rci -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -MODLDVD = ${SRCLIBDIR}/libdvd90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 -GRASPLIBS = -l9290 -lmod -lrang90 -lmcp90 -ldvd90 -l9290 +OBJS= \ + evcout.o \ + dspevx_I.o \ + ratden_I.o \ + talk.o \ + talk_I.o \ + cxk.o \ + cxk_I.o \ + bessel.o \ + bessel_I.o \ + dnicmv.o \ + dnicmv_I.o \ + engout.o \ + engout_I.o \ + funk.o \ + funk_I.o \ + funl.o \ + funl_I.o \ + mohr.o \ + mohr_I.o \ + klamaq.o \ + klamaq_I.o \ + fzalf.o \ + fzalf_I.o \ + breid.o \ + breid_I.o \ + zkf.o \ + zkf_I.o \ + rkint.o \ + rkint_I.o \ + rkintc.o \ + rkintc_I.o \ + skint.o \ + skint_I.o \ + brra.o \ + brra_I.o \ + brintf.o \ + brintf_I.o \ + brint1.o \ + brint1_I.o \ + brint2.o \ + brint2_I.o \ + brint3.o \ + brint3_I.o \ + brint4.o \ + brint4_I.o \ + brint5.o \ + brint5_I.o \ + brint6.o \ + brint6_I.o \ + triangbreit1.o \ + triangbreit1_I.o \ + triangbreit2.o \ + triangbreit2_I.o \ + genintbreit1.o \ + genintbreit1_I.o \ + genintbreit2.o \ + genintbreit2_I.o \ + genintrk.o \ + genintrk_I.o \ + getcid.o \ + getcid_I.o \ + hmout.o \ + hmout_I.o \ + hovlap.o \ + hovlap_I.o \ + iabint.o \ + iabint_I.o \ + indtpi.o \ + indtpi_I.o \ + iniestdm.o \ + iniestdm_I.o \ + iniestsd.o \ + iniestsd_I.o \ + keint.o \ + keint_I.o \ + lodmix.o \ + lodmix_I.o \ + lodres.o \ + lodres_I.o \ + spodmv.o \ + spodmv_I.o \ + maneig.o \ + maneig_I.o \ + ncharg.o \ + ncharg_I.o \ + qed.o \ + qed_I.o \ + qed_slfen.o \ + qed_slfen_I.o \ + setcsl.o \ + setcsl_I.o \ + setdbg.o \ + setdbg_I.o \ + setmix.o \ + setmix_I.o \ + setres.o \ + setres_I.o \ + setsum.o \ + setsum_I.o \ + shield.o \ + shield_I.o \ + strsum.o \ + strsum_I.o \ + triangrk.o \ + triangrk_I.o \ + vac2.o \ + vac2_I.o \ + vac4.o \ + vac4_I.o \ + vacpol.o \ + vacpol_I.o \ + vinti.o \ + vinti_I.o \ + vint.o \ + vint_I.o \ + vpintf.o \ + vpintf_I.o \ + vpint.o \ + vpint_I.o \ + wghtd5.o \ + wghtd5_I.o \ + setham_gg.o \ + setham_gg_I.o \ + genmat.o \ + genmat_I.o \ + genmat2.o \ + genmat2_I.o \ + auxblk.o \ + auxblk_I.o \ + matrix.o \ + matrix_I.o \ + rci92.o -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -APP_OBJ= \ - iabint_I.o funk_I.o ncharg_I.o skint_I.o \ - auxblk_I.o funl_I.o qed_I.o \ - bessel_I.o fzalf_I.o qed_slfen_I.o spodmv_I.o \ - breid_I.o genmat2_I.o ratden_I.o strsum_I.o \ - genmat_I.o rkint_I.o talk_I.o \ - brint1_I.o brint2_I.o brint3_I.o brint4_I.o \ - brint5_I.o brint6_I.o keint_I.o vint_I.o \ - vpint_I.o lodmix_I.o getcid_I.o\ - brintf_I.o hmout_I.o rkintc_I.o triangrk_I.o \ - brra_I.o hovlap_I.o setcsl_I.o vac2_I.o \ - cxk_I.o indtpi_I.o setdbg_I.o vac4_I.o \ - dmerge_dnicmv_I.o klamaq_I.o setmix_I.o vacpol_I.o \ - dnicmv_I.o lodres_I.o setres_I.o vinti_I.o \ - dspevx_I.o maneig_I.o setsum_I.o zkf_I.o \ - engout_I.o mohr_I.o shield_I.o setham_gg_I.o\ - vpintf_I.o iniestdm_I.o iniestsd_I.o wghtd5_I.o \ - matrix_I.o genintbreit1_I.o triangbreit1_I.o genintbreit2_I.o \ - triangbreit2_I.o \ - auxblk.o bessel.o breid.o brint1.o brint2.o brint3.o brint4.o \ - brint5.o brint6.o brintf.o brra.o cxk.o engout.o evcout.o funk.o \ - funl.o fzalf.o genintrk.o genmat.o hmout.o hovlap.o iabint.o indtpi.o \ - keint.o klamaq.o mohr.o ncharg.o qed.o rkint.o rkintc.o setdbg.o \ - setsum.o skint.o talk.o triangrk.o vac2.o vac4.o vacpol.o \ - vint.o vinti.o vpint.o vpintf.o wghtd5.o zkf.o \ - dnicmv.o genmat2.o getcid.o iniestdm.o iniestsd.o lodmix.o lodres.o \ - maneig.o rci92.o setcsl.o setham_gg.o setmix.o setres.o \ - spodmv.o strsum.o shield.o qed_slfen.o matrix.o genintbreit1.o triangbreit1.o \ - genintbreit2.o triangbreit2.o # genintbreit1wrap.o genintbreit2wrap.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ - -I $(MODDIR) -I $(MODLDVD) -I $(MODLMPIU90) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rci90_mpi/BUILDCONF.sh b/src/appl/rci90_mpi/BUILDCONF.sh new file mode 100644 index 000000000..4d72a7cc5 --- /dev/null +++ b/src/appl/rci90_mpi/BUILDCONF.sh @@ -0,0 +1,87 @@ +EXE=rci_mpi +LIBRARIES="mpiu90 rang90 9290 dvd90 mod" +LAPACK=true +ISMPI=true +FILES=" +# Missing interface +evcout.f90 + +# Missing implementation +#dspevx.f90 dspevx_I.f90 +dspevx_I.f90 + +# Missing implementation & not referenced in the original makefile +#gdsummpi_I.f90 +ratden_I.f90 + +bessel.f90 bessel_I.f90 +zkf.f90 zkf_I.f90 +rkintc.f90 rkintc_I.f90 +rkint.f90 rkint_I.f90 +skint.f90 skint_I.f90 +brra.f90 brra_I.f90 +brintf.f90 brintf_I.f90 +talk.f90 talk_I.f90 +cxk.f90 cxk_I.f90 +breid.f90 breid_I.f90 +brint1.f90 brint1_I.f90 +brint2.f90 brint2_I.f90 +brint3.f90 brint3_I.f90 +brint4.f90 brint4_I.f90 +brint5.f90 brint5_I.f90 +brint6.f90 brint6_I.f90 +dnicmv.f90 dnicmv_I.f90 +engout.f90 engout_I.f90 +funk.f90 funk_I.f90 +funl.f90 funl_I.f90 +mohr.f90 mohr_I.f90 +klamaq.f90 klamaq_I.f90 +fzalf.f90 fzalf_I.f90 +triangbreit1.f90 triangbreit1_I.f90 +triangbreit2.f90 triangbreit2_I.f90 +triangrk.f90 triangrk_I.f90 +genintbreit1.f90 genintbreit1_I.f90 +genintbreit1wrap.f90 genintbreit1wrap_I.f90 +genintbreit2.f90 genintbreit2_I.f90 +genintbreit2wrap.f90 genintbreit2wrap_I.f90 +genintrk.f90 genintrk_I.f90 +genintrkwrap.f90 genintrkwrap_I.f90 +getcid.f90 getcid_I.f90 +hmout.f90 hmout_I.f90 +hovlap.f90 hovlap_I.f90 +iabint.f90 iabint_I.f90 +indtpi.f90 indtpi_I.f90 +iniestdm.f90 iniestdm_I.f90 +iniestsd.f90 iniestsd_I.f90 +keint.f90 keint_I.f90 +lodmixmpi.f90 lodmixmpi_I.f90 +lodres.f90 lodres_I.f90 +spodmv.f90 spodmv_I.f90 +maneigmpi.f90 maneigmpi_I.f90 +ncharg.f90 ncharg_I.f90 +qed_slfen.f90 qed_slfen_I.f90 +qed.f90 qed_I.f90 +setdbg.f90 setdbg_I.f90 +setmixmpi.f90 setmixmpi_I.f90 +setres.f90 setres_I.f90 +setsum.f90 setsum_I.f90 +snrc.f90 snrc_I.f90 +strsum.f90 strsum_I.f90 +vac2.f90 vac2_I.f90 +vac4.f90 vac4_I.f90 +vacpol.f90 vacpol_I.f90 +vinti.f90 vinti_I.f90 +vint.f90 vint_I.f90 +vpintf.f90 vpintf_I.f90 +vpint.f90 vpint_I.f90 +wghtd5.f90 wghtd5_I.f90 +auxblk.f90 auxblk_I.f90 +setham_gg.f90 setham_gg_I.f90 +genmat.f90 genmat_I.f90 +genmat2.f90 genmat2_I.f90 +matrix.f90 matrix_I.f90 + +rci90mpi.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rci90_mpi/CMakeLists.txt b/src/appl/rci90_mpi/CMakeLists.txt new file mode 100644 index 000000000..ef9e12499 --- /dev/null +++ b/src/appl/rci90_mpi/CMakeLists.txt @@ -0,0 +1,140 @@ +add_executable(rci_mpi + evcout.f90 + dspevx_I.f90 + ratden_I.f90 + bessel.f90 + bessel_I.f90 + zkf.f90 + zkf_I.f90 + rkintc.f90 + rkintc_I.f90 + rkint.f90 + rkint_I.f90 + skint.f90 + skint_I.f90 + brra.f90 + brra_I.f90 + brintf.f90 + brintf_I.f90 + talk.f90 + talk_I.f90 + cxk.f90 + cxk_I.f90 + breid.f90 + breid_I.f90 + brint1.f90 + brint1_I.f90 + brint2.f90 + brint2_I.f90 + brint3.f90 + brint3_I.f90 + brint4.f90 + brint4_I.f90 + brint5.f90 + brint5_I.f90 + brint6.f90 + brint6_I.f90 + dnicmv.f90 + dnicmv_I.f90 + engout.f90 + engout_I.f90 + funk.f90 + funk_I.f90 + funl.f90 + funl_I.f90 + mohr.f90 + mohr_I.f90 + klamaq.f90 + klamaq_I.f90 + fzalf.f90 + fzalf_I.f90 + triangbreit1.f90 + triangbreit1_I.f90 + triangbreit2.f90 + triangbreit2_I.f90 + triangrk.f90 + triangrk_I.f90 + genintbreit1.f90 + genintbreit1_I.f90 + genintbreit1wrap.f90 + genintbreit1wrap_I.f90 + genintbreit2.f90 + genintbreit2_I.f90 + genintbreit2wrap.f90 + genintbreit2wrap_I.f90 + genintrk.f90 + genintrk_I.f90 + genintrkwrap.f90 + genintrkwrap_I.f90 + getcid.f90 + getcid_I.f90 + hmout.f90 + hmout_I.f90 + hovlap.f90 + hovlap_I.f90 + iabint.f90 + iabint_I.f90 + indtpi.f90 + indtpi_I.f90 + iniestdm.f90 + iniestdm_I.f90 + iniestsd.f90 + iniestsd_I.f90 + keint.f90 + keint_I.f90 + lodmixmpi.f90 + lodmixmpi_I.f90 + lodres.f90 + lodres_I.f90 + spodmv.f90 + spodmv_I.f90 + maneigmpi.f90 + maneigmpi_I.f90 + ncharg.f90 + ncharg_I.f90 + qed_slfen.f90 + qed_slfen_I.f90 + qed.f90 + qed_I.f90 + setdbg.f90 + setdbg_I.f90 + setmixmpi.f90 + setmixmpi_I.f90 + setres.f90 + setres_I.f90 + setsum.f90 + setsum_I.f90 + snrc.f90 + snrc_I.f90 + strsum.f90 + strsum_I.f90 + vac2.f90 + vac2_I.f90 + vac4.f90 + vac4_I.f90 + vacpol.f90 + vacpol_I.f90 + vinti.f90 + vinti_I.f90 + vint.f90 + vint_I.f90 + vpintf.f90 + vpintf_I.f90 + vpint.f90 + vpint_I.f90 + wghtd5.f90 + wghtd5_I.f90 + auxblk.f90 + auxblk_I.f90 + setham_gg.f90 + setham_gg_I.f90 + genmat.f90 + genmat_I.f90 + genmat2.f90 + genmat2_I.f90 + matrix.f90 + matrix_I.f90 + rci90mpi.f90 +) +target_link_libraries_Fortran(rci_mpi PUBLIC mpiu90 rang90 9290 dvd90 mod) +install(TARGETS rci_mpi DESTINATION bin/) diff --git a/src/appl/rci90_mpi/Makefile b/src/appl/rci90_mpi/Makefile index c94857c6e..d58e29d47 100644 --- a/src/appl/rci90_mpi/Makefile +++ b/src/appl/rci90_mpi/Makefile @@ -1,66 +1,151 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rci_mpi +LIBS=-L ${GRASP}/lib/ -lmpiu90 -lrang90 -l9290 -ldvd90 -lmod +FC_MODULES= -I ${GRASP}/src/lib/mpi90 -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/libmod -EXE = rci_mpi -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -MODLDVD = ${SRCLIBDIR}/libdvd90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 +OBJS= \ + evcout.o \ + dspevx_I.o \ + ratden_I.o \ + bessel.o \ + bessel_I.o \ + zkf.o \ + zkf_I.o \ + rkintc.o \ + rkintc_I.o \ + rkint.o \ + rkint_I.o \ + skint.o \ + skint_I.o \ + brra.o \ + brra_I.o \ + brintf.o \ + brintf_I.o \ + talk.o \ + talk_I.o \ + cxk.o \ + cxk_I.o \ + breid.o \ + breid_I.o \ + brint1.o \ + brint1_I.o \ + brint2.o \ + brint2_I.o \ + brint3.o \ + brint3_I.o \ + brint4.o \ + brint4_I.o \ + brint5.o \ + brint5_I.o \ + brint6.o \ + brint6_I.o \ + dnicmv.o \ + dnicmv_I.o \ + engout.o \ + engout_I.o \ + funk.o \ + funk_I.o \ + funl.o \ + funl_I.o \ + mohr.o \ + mohr_I.o \ + klamaq.o \ + klamaq_I.o \ + fzalf.o \ + fzalf_I.o \ + triangbreit1.o \ + triangbreit1_I.o \ + triangbreit2.o \ + triangbreit2_I.o \ + triangrk.o \ + triangrk_I.o \ + genintbreit1.o \ + genintbreit1_I.o \ + genintbreit1wrap.o \ + genintbreit1wrap_I.o \ + genintbreit2.o \ + genintbreit2_I.o \ + genintbreit2wrap.o \ + genintbreit2wrap_I.o \ + genintrk.o \ + genintrk_I.o \ + genintrkwrap.o \ + genintrkwrap_I.o \ + getcid.o \ + getcid_I.o \ + hmout.o \ + hmout_I.o \ + hovlap.o \ + hovlap_I.o \ + iabint.o \ + iabint_I.o \ + indtpi.o \ + indtpi_I.o \ + iniestdm.o \ + iniestdm_I.o \ + iniestsd.o \ + iniestsd_I.o \ + keint.o \ + keint_I.o \ + lodmixmpi.o \ + lodmixmpi_I.o \ + lodres.o \ + lodres_I.o \ + spodmv.o \ + spodmv_I.o \ + maneigmpi.o \ + maneigmpi_I.o \ + ncharg.o \ + ncharg_I.o \ + qed_slfen.o \ + qed_slfen_I.o \ + qed.o \ + qed_I.o \ + setdbg.o \ + setdbg_I.o \ + setmixmpi.o \ + setmixmpi_I.o \ + setres.o \ + setres_I.o \ + setsum.o \ + setsum_I.o \ + snrc.o \ + snrc_I.o \ + strsum.o \ + strsum_I.o \ + vac2.o \ + vac2_I.o \ + vac4.o \ + vac4_I.o \ + vacpol.o \ + vacpol_I.o \ + vinti.o \ + vinti_I.o \ + vint.o \ + vint_I.o \ + vpintf.o \ + vpintf_I.o \ + vpint.o \ + vpint_I.o \ + wghtd5.o \ + wghtd5_I.o \ + auxblk.o \ + auxblk_I.o \ + setham_gg.o \ + setham_gg_I.o \ + genmat.o \ + genmat_I.o \ + genmat2.o \ + genmat2_I.o \ + matrix.o \ + matrix_I.o \ + rci90mpi.o -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 -lmpiu90 -l9290 +$(EXE): $(OBJS) + $(FC_MPI) -o $@ $? $(FC_MPILD) $(LIBS) $(LAPACK_LIBS) - -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - iabint_I.o funk_I.o ncharg_I.o skint_I.o \ - auxblk_I.o funl_I.o qed_I.o snrc_I.o \ - bessel_I.o fzalf_I.o qed_slfen_I.o spodmv_I.o \ - breid_I.o genmat2_I.o ratden_I.o strsum_I.o \ - dspevx_I.o genmat_I.o rkint_I.o talk_I.o \ - brint1_I.o brint2_I.o brint3_I.o brint4_I.o \ - brint5_I.o brint6_I.o keint_I.o vint_I.o \ - genintrkwrap_I.o genintrk_I.o \ - vpint_I.o lodmixmpi_I.o getcid_I.o\ - brintf_I.o hmout_I.o rkintc_I.o triangrk_I.o \ - brra_I.o hovlap_I.o vac2_I.o \ - cxk_I.o indtpi_I.o setdbg_I.o vac4_I.o \ - klamaq_I.o setmixmpi_I.o vacpol_I.o \ - dnicmv_I.o lodres_I.o setres_I.o vinti_I.o \ - maneigmpi_I.o setsum_I.o zkf_I.o \ - engout_I.o mohr_I.o setham_gg_I.o\ - vpintf_I.o iniestdm_I.o iniestsd_I.o wghtd5_I.o \ - matrix_I.o genintbreit1_I.o triangbreit1_I.o genintbreit2_I.o \ - triangbreit2_I.o genintbreit1wrap_I.o genintbreit2wrap_I.o \ - auxblk.o bessel.o breid.o brint1.o brint2.o brint3.o brint4.o \ - brint5.o brint6.o brintf.o brra.o cxk.o engout.o evcout.o funk.o \ - funl.o fzalf.o genintrk.o genmat.o hmout.o hovlap.o iabint.o indtpi.o \ - keint.o klamaq.o mohr.o ncharg.o qed.o rkint.o rkintc.o setdbg.o \ - setsum.o skint.o snrc.o talk.o triangrk.o vac2.o vac4.o vacpol.o \ - genintrkwrap.o vint.o vinti.o vpint.o vpintf.o wghtd5.o zkf.o \ - dnicmv.o genmat2.o getcid.o iniestdm.o iniestsd.o lodmixmpi.o lodres.o \ - maneigmpi.o rci90mpi.o setham_gg.o setmixmpi.o setres.o \ - spodmv.o strsum.o qed_slfen.o matrix.o genintbreit1.o triangbreit1.o \ - genintbreit2.o triangbreit2.o genintbreit1wrap.o genintbreit2wrap.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) $(LAPACK_LIBS) - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ - -I $(MODDIR) -I $(MODLDVD) -I $(MODLMPIU90) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rcsfgenerate90/BUILDCONF.sh b/src/appl/rcsfgenerate90/BUILDCONF.sh new file mode 100644 index 000000000..5bc52e300 --- /dev/null +++ b/src/appl/rcsfgenerate90/BUILDCONF.sh @@ -0,0 +1,42 @@ +EXE=rcsfgenerate +LIBRARIES="mod 9290 rang90" +FILES=" +lockad.f90 lockad_I.f90 +reada.f90 reada_I.f90 +lasa1.f90 lasa1_I.f90 +lasa2.f90 lasa2_I.f90 +adder.f90 adder_I.f90 +slug.f90 slug_I.f90 +sluggo.f90 sluggo_I.f90 +kopp1.f90 kopp1_I.f90 +kopp2.f90 kopp2_I.f90 +genb.f90 gen_I.f90 # Implementation file called genb.f90 +copy7t9.f90 copy7t9_I.f90 +fivefirst.f90 fivefirst_I.f90 +fivelines.f90 fivelines_I.f90 +lika.f90 lika_I.f90 +matain.f90 matain_I.f90 +matbin.f90 matbin_I.f90 +matcin.f90 matcin_I.f90 +test.f90 test_I.f90 +merge.f90 merge_I.f90 +mergeb.f90 mergeb_I.f90 +open79.f90 open79_I.f90 +reffa.f90 reffa_I.f90 +blanda.f90 blanda_I.f90 +blandb.f90 blandb_I.f90 +blandc.f90 blandc_I.f90 + +# Missing interface +jjgen15b.f90 +rcsfblock.f90 +rcsfexcitation.f90 + +wrapper.f90 # main program + +# Not referenced in the original makefile +#lasax-reada.f90 +#m.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rcsfgenerate90/CMakeLists.txt b/src/appl/rcsfgenerate90/CMakeLists.txt new file mode 100644 index 000000000..1f61eb17d --- /dev/null +++ b/src/appl/rcsfgenerate90/CMakeLists.txt @@ -0,0 +1,58 @@ +add_executable(rcsfgenerate + lockad.f90 + lockad_I.f90 + reada.f90 + reada_I.f90 + lasa1.f90 + lasa1_I.f90 + lasa2.f90 + lasa2_I.f90 + adder.f90 + adder_I.f90 + slug.f90 + slug_I.f90 + sluggo.f90 + sluggo_I.f90 + kopp1.f90 + kopp1_I.f90 + kopp2.f90 + kopp2_I.f90 + genb.f90 + gen_I.f90 + copy7t9.f90 + copy7t9_I.f90 + fivefirst.f90 + fivefirst_I.f90 + fivelines.f90 + fivelines_I.f90 + lika.f90 + lika_I.f90 + matain.f90 + matain_I.f90 + matbin.f90 + matbin_I.f90 + matcin.f90 + matcin_I.f90 + test.f90 + test_I.f90 + merge.f90 + merge_I.f90 + mergeb.f90 + mergeb_I.f90 + open79.f90 + open79_I.f90 + reffa.f90 + reffa_I.f90 + blanda.f90 + blanda_I.f90 + blandb.f90 + blandb_I.f90 + blandc.f90 + blandc_I.f90 + jjgen15b.f90 + rcsfblock.f90 + rcsfexcitation.f90 + wrapper.f90 +) +target_link_libraries_Fortran(rcsfgenerate PUBLIC mod 9290 rang90) +install(TARGETS rcsfgenerate DESTINATION bin/) diff --git a/src/appl/rcsfgenerate90/Makefile b/src/appl/rcsfgenerate90/Makefile index 618c270a0..153550481 100644 --- a/src/appl/rcsfgenerate90/Makefile +++ b/src/appl/rcsfgenerate90/Makefile @@ -1,40 +1,69 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rcsfgenerate +LIBS=-L ${GRASP}/lib/ -lmod -l9290 -lrang90 +FC_MODULES= -I ${GRASP}/src/lib/libmod -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/librang90 -EXE = rcsfgenerate -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -GRASPLIBS =-l9290 -lmod -FC = gfortran -FC_FLAGS = -fno-automatic +OBJS= \ + lockad.o \ + lockad_I.o \ + reada.o \ + reada_I.o \ + lasa1.o \ + lasa1_I.o \ + lasa2.o \ + lasa2_I.o \ + adder.o \ + adder_I.o \ + slug.o \ + slug_I.o \ + sluggo.o \ + sluggo_I.o \ + kopp1.o \ + kopp1_I.o \ + kopp2.o \ + kopp2_I.o \ + genb.o \ + gen_I.o \ + copy7t9.o \ + copy7t9_I.o \ + fivefirst.o \ + fivefirst_I.o \ + fivelines.o \ + fivelines_I.o \ + lika.o \ + lika_I.o \ + matain.o \ + matain_I.o \ + matbin.o \ + matbin_I.o \ + matcin.o \ + matcin_I.o \ + test.o \ + test_I.o \ + merge.o \ + merge_I.o \ + mergeb.o \ + mergeb_I.o \ + open79.o \ + open79_I.o \ + reffa.o \ + reffa_I.o \ + blanda.o \ + blanda_I.o \ + blandb.o \ + blandb_I.o \ + blandc.o \ + blandc_I.o \ + jjgen15b.o \ + rcsfblock.o \ + rcsfexcitation.o \ + wrapper.o -MOD_OBJ= \ - adder_I.o fivefirst_I.o lasa2_I.o matcin_I.o reffa_I.o \ - blanda_I.o fivelines_I.o lika_I.o mergeb_I.o sluggo_I.o \ - blandb_I.o kopp1_I.o lockad_I.o merge_I.o slug_I.o \ - blandc_I.o kopp2_I.o matain_I.o open79_I.o test_I.o \ - copy7t9_I.o lasa1_I.o matbin_I.o reada_I.o gen_I.o +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) -APP_OBJ= \ - adder.o blanda.o blandc.o blandb.o fivefirst.o fivelines.o \ - genb.o jjgen15b.o kopp1.o kopp2.o lasa1.o lasa2.o lika.o \ - lockad.o matain.o matcin.o matbin.o merge.o mergeb.o \ - reada.o reffa.o slug.o sluggo.o test.o copy7t9.o open79.o \ - rcsfblock.o rcsfexcitation.o wrapper.o - -$(EXE): $(MOD_OBJ) $(APP_OBJ) - $(FC) -o $(BINFILE) $(LD_FLAGS) $(APP_OBJ) -L$(GRASPLIB) $(GRASPLIBS) - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I . -I ${MODDIR} -I $(MODL9290) -o $@ - - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rcsfinteract90/BUILDCONF.sh b/src/appl/rcsfinteract90/BUILDCONF.sh new file mode 100644 index 000000000..5b14e7199 --- /dev/null +++ b/src/appl/rcsfinteract90/BUILDCONF.sh @@ -0,0 +1,34 @@ +EXE=rcsfinteract +LIBRARIES="rang90 9290 mod" +FILES=" +onescalar1INT.f90 onescalar1INT_I.f90 +onescalar2INT.f90 onescalar2INT_I.f90 +onescalarINT.f90 onescalarINT_I.f90 +el1INT.f90 el1INT_I.f90 +el2INT.f90 el2INT_I.f90 +el31INT.f90 el31INT_I.f90 +el32INT.f90 el32INT_I.f90 +el33INT.f90 el33INT_I.f90 +el3INT.f90 el3INT_I.f90 +el41INT.f90 el41INT_I.f90 +el4INT.f90 el4INT_I.f90 +el51INT.f90 el51INT_I.f90 +el52INT.f90 el52INT_I.f90 +el53INT.f90 el53INT_I.f90 +el5INT.f90 el5INT_I.f90 +Interact_MR.f90 Interact_MR_I.f90 +Interact_csf.f90 Interact_csf_I.f90 +getinf.f90 getinf_I.f90 +lodcsl_CSF.f90 lodcsl_CSF_I.f90 +lodcsl_MR.f90 lodcsl_MR_I.f90 +set_CSF_list.f90 set_CSF_list_I.f90 +set_CSF_number.f90 set_CSF_number_I.f90 + +RCSFinteract.f90 + +# Not referenced in the original makefile +#recoonescalar.f90 recoonescalar_I.f90 +#el52_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rcsfinteract90/CMakeLists.txt b/src/appl/rcsfinteract90/CMakeLists.txt new file mode 100644 index 000000000..a83ebf21c --- /dev/null +++ b/src/appl/rcsfinteract90/CMakeLists.txt @@ -0,0 +1,49 @@ +add_executable(rcsfinteract + onescalar1INT.f90 + onescalar1INT_I.f90 + onescalar2INT.f90 + onescalar2INT_I.f90 + onescalarINT.f90 + onescalarINT_I.f90 + el1INT.f90 + el1INT_I.f90 + el2INT.f90 + el2INT_I.f90 + el31INT.f90 + el31INT_I.f90 + el32INT.f90 + el32INT_I.f90 + el33INT.f90 + el33INT_I.f90 + el3INT.f90 + el3INT_I.f90 + el41INT.f90 + el41INT_I.f90 + el4INT.f90 + el4INT_I.f90 + el51INT.f90 + el51INT_I.f90 + el52INT.f90 + el52INT_I.f90 + el53INT.f90 + el53INT_I.f90 + el5INT.f90 + el5INT_I.f90 + Interact_MR.f90 + Interact_MR_I.f90 + Interact_csf.f90 + Interact_csf_I.f90 + getinf.f90 + getinf_I.f90 + lodcsl_CSF.f90 + lodcsl_CSF_I.f90 + lodcsl_MR.f90 + lodcsl_MR_I.f90 + set_CSF_list.f90 + set_CSF_list_I.f90 + set_CSF_number.f90 + set_CSF_number_I.f90 + RCSFinteract.f90 +) +target_link_libraries_Fortran(rcsfinteract PUBLIC rang90 9290 mod) +install(TARGETS rcsfinteract DESTINATION bin/) diff --git a/src/appl/rcsfinteract90/Makefile b/src/appl/rcsfinteract90/Makefile index 9eac3eb20..d54352491 100644 --- a/src/appl/rcsfinteract90/Makefile +++ b/src/appl/rcsfinteract90/Makefile @@ -1,48 +1,60 @@ -.SUFFIXES: .f90 .mod - -EXE = rcsfinteract -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -GRASPLIBS =-l9290 -lmod -lrang90 - -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - getinf_I.o Interact_MR_I.o \ - lodcsl_MR_I.o lodcsl_CSF_I.o \ - set_CSF_list_I.o set_CSF_number_I.o \ - onescalarINT_I.o onescalar1INT_I.o onescalar2INT_I.o \ - el1INT_I.o el2INT_I.o el3INT_I.o el31INT_I.o el32INT_I.o \ - el33INT_I.o el4INT_I.o el41INT_I.o \ - el5INT_I.o el51INT_I.o el52INT_I.o el53INT_I.o Interact_csf_I.o \ -\ - RCSFinteract.o getinf.o Interact_MR.o \ - lodcsl_MR.o lodcsl_CSF.o \ - set_CSF_list.o set_CSF_number.o \ - onescalarINT.o onescalar1INT.o onescalar2INT.o \ - el1INT.o el2INT.o el3INT.o el31INT.o el32INT.o el33INT.o \ - el4INT.o el41INT.o \ - el5INT.o el51INT.o el52INT.o el53INT.o Interact_csf.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) - - - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL9290} -I $(MODLRANG90) -I $(MODDIR) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +EXE=${GRASP}/bin/rcsfinteract +LIBS=-L ${GRASP}/lib/ -lrang90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod + +OBJS= \ + onescalar1INT.o \ + onescalar1INT_I.o \ + onescalar2INT.o \ + onescalar2INT_I.o \ + onescalarINT.o \ + onescalarINT_I.o \ + el1INT.o \ + el1INT_I.o \ + el2INT.o \ + el2INT_I.o \ + el31INT.o \ + el31INT_I.o \ + el32INT.o \ + el32INT_I.o \ + el33INT.o \ + el33INT_I.o \ + el3INT.o \ + el3INT_I.o \ + el41INT.o \ + el41INT_I.o \ + el4INT.o \ + el4INT_I.o \ + el51INT.o \ + el51INT_I.o \ + el52INT.o \ + el52INT_I.o \ + el53INT.o \ + el53INT_I.o \ + el5INT.o \ + el5INT_I.o \ + Interact_MR.o \ + Interact_MR_I.o \ + Interact_csf.o \ + Interact_csf_I.o \ + getinf.o \ + getinf_I.o \ + lodcsl_CSF.o \ + lodcsl_CSF_I.o \ + lodcsl_MR.o \ + lodcsl_MR_I.o \ + set_CSF_list.o \ + set_CSF_list_I.o \ + set_CSF_number.o \ + set_CSF_number_I.o \ + RCSFinteract.o + +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) + +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rcsfzerofirst90/BUILDCONF.sh b/src/appl/rcsfzerofirst90/BUILDCONF.sh new file mode 100644 index 000000000..81edb43ef --- /dev/null +++ b/src/appl/rcsfzerofirst90/BUILDCONF.sh @@ -0,0 +1,11 @@ +EXE=rcsfzerofirst +LIBRARIES="9290 mod" +FILES=" +lodcsl_Part.f90 lodcsl_Part_I.f90 +lodcsl_Zero.f90 lodcsl_Zero_I.f90 +set_CSF_number.f90 set_CSF_number_I.f90 +set_CSF_ZFlist.f90 set_CSF_ZFlist_I.f90 +RCSFzerofirst.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rcsfzerofirst90/CMakeLists.txt b/src/appl/rcsfzerofirst90/CMakeLists.txt new file mode 100644 index 000000000..dd46e5da0 --- /dev/null +++ b/src/appl/rcsfzerofirst90/CMakeLists.txt @@ -0,0 +1,13 @@ +add_executable(rcsfzerofirst + lodcsl_Part.f90 + lodcsl_Part_I.f90 + lodcsl_Zero.f90 + lodcsl_Zero_I.f90 + set_CSF_number.f90 + set_CSF_number_I.f90 + set_CSF_ZFlist.f90 + set_CSF_ZFlist_I.f90 + RCSFzerofirst.f90 +) +target_link_libraries_Fortran(rcsfzerofirst PUBLIC 9290 mod) +install(TARGETS rcsfzerofirst DESTINATION bin/) diff --git a/src/appl/rcsfzerofirst90/Makefile b/src/appl/rcsfzerofirst90/Makefile index ea1df2db3..01c3ec28d 100644 --- a/src/appl/rcsfzerofirst90/Makefile +++ b/src/appl/rcsfzerofirst90/Makefile @@ -1,36 +1,24 @@ -.SUFFIXES: .f90 .mod - -EXE = rcsfzerofirst -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -GRASPLIBS =-l9290 -lmod - -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} - -# Define data types -#VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - lodcsl_Zero_I.o lodcsl_Part_I.o \ - set_CSF_ZFlist_I.o set_CSF_number_I.o \ -\ - RCSFzerofirst.o \ - lodcsl_Zero.o lodcsl_Part.o \ - set_CSF_ZFlist.o set_CSF_number.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL9290} -I $(MODDIR) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +EXE=${GRASP}/bin/rcsfzerofirst +LIBS=-L ${GRASP}/lib/ -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod + +OBJS= \ + lodcsl_Part.o \ + lodcsl_Part_I.o \ + lodcsl_Zero.o \ + lodcsl_Zero_I.o \ + set_CSF_number.o \ + set_CSF_number_I.o \ + set_CSF_ZFlist.o \ + set_CSF_ZFlist_I.o \ + RCSFzerofirst.o + +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) + +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rhfs90/BUILDCONF.sh b/src/appl/rhfs90/BUILDCONF.sh new file mode 100644 index 000000000..1a03f7819 --- /dev/null +++ b/src/appl/rhfs90/BUILDCONF.sh @@ -0,0 +1,18 @@ +EXE=rhfs +LIBRARIES="rang90 mcp90 9290 mod" +LAPACK=true +FILES=" +engouth.f90 engouth_I.f90 +gethfd.f90 gethfd_I.f90 +getmixblock.f90 getmixblock_I.f90 +opt6_C.f90 +matelt.f90 matelt_I.f90 +rinthf.f90 rinthf_I.f90 +setdbg.f90 setdbg_I.f90 +setsum.f90 setsum_I.f90 +strsum.f90 strsum_I.f90 +hfsgg.f90 hfsgg_I.f90 +hfs92.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rhfs90/CMakeLists.txt b/src/appl/rhfs90/CMakeLists.txt new file mode 100644 index 000000000..a2ee5caba --- /dev/null +++ b/src/appl/rhfs90/CMakeLists.txt @@ -0,0 +1,24 @@ +add_executable(rhfs + engouth.f90 + engouth_I.f90 + gethfd.f90 + gethfd_I.f90 + getmixblock.f90 + getmixblock_I.f90 + opt6_C.f90 + matelt.f90 + matelt_I.f90 + rinthf.f90 + rinthf_I.f90 + setdbg.f90 + setdbg_I.f90 + setsum.f90 + setsum_I.f90 + strsum.f90 + strsum_I.f90 + hfsgg.f90 + hfsgg_I.f90 + hfs92.f90 +) +target_link_libraries_Fortran(rhfs PUBLIC rang90 mcp90 9290 mod) +install(TARGETS rhfs DESTINATION bin/) diff --git a/src/appl/rhfs90/Makefile b/src/appl/rhfs90/Makefile index 89a752f6d..50051fed8 100644 --- a/src/appl/rhfs90/Makefile +++ b/src/appl/rhfs90/Makefile @@ -1,35 +1,35 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rhfs +LIBS=-L ${GRASP}/lib/ -lrang90 -lmcp90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rhfs -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 +OBJS= \ + engouth.o \ + engouth_I.o \ + gethfd.o \ + gethfd_I.o \ + getmixblock.o \ + getmixblock_I.o \ + opt6_C.o \ + matelt.o \ + matelt_I.o \ + rinthf.o \ + rinthf_I.o \ + setdbg.o \ + setdbg_I.o \ + setsum.o \ + setsum_I.o \ + strsum.o \ + strsum_I.o \ + hfsgg.o \ + hfsgg_I.o \ + hfs92.o -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -APP_OBJ= opt6_C.o\ - getmixblock_I.o rinthf_I.o strsum_I.o \ - engouth_I.o hfsgg_I.o setdbg_I.o \ - gethfd_I.o matelt_I.o setsum_I.o \ - \ - engouth.o gethfd.o hfsgg.o hfs92.o matelt.o rinthf.o \ - setdbg.o setsum.o strsum.o getmixblock.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ - -I $(MODDIR) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rmcdhf90/BUILDCONF.sh b/src/appl/rmcdhf90/BUILDCONF.sh new file mode 100644 index 000000000..b4867c9fe --- /dev/null +++ b/src/appl/rmcdhf90/BUILDCONF.sh @@ -0,0 +1,65 @@ +EXE=rmcdhf +LIBRARIES="dvd90 9290 mod" +LAPACK=true +FILES=" +mpi_s.f90 + +dsubrs.f90 dsubrs_I.f90 +fco.f90 fco_I.f90 +gco.f90 gco_I.f90 +setcof.f90 setcof_I.f90 +lodcsh2GG.f90 lodcsh2GG_I.f90 +setcsl.f90 setcsl_I.f90 +setdbg.f90 setdbg_I.f90 +setham.f90 setham_I.f90 +xpot.f90 xpot_I.f90 +ypot.f90 ypot_I.f90 +dacon.f90 dacon_I.f90 +dampck.f90 dampck_I.f90 +setlag.f90 setlag_I.f90 +setmcp.f90 setmcp_I.f90 +setmix.f90 setmix_I.f90 +setsum.f90 setsum_I.f90 +setxuv.f90 setxuv_I.f90 +setxv.f90 setxv_I.f90 +setxz.f90 setxz_I.f90 +lagcon.f90 lagcon_I.f90 +cofpot.f90 cofpot_I.f90 +consis.f90 consis_I.f90 +csfwgt.f90 csfwgt_I.f90 +dampor.f90 dampor_I.f90 +defcor.f90 defcor_I.f90 +eigen.f90 eigen_I.f90 +engoutgg.f90 engoutgg_I.f90 +endsum.f90 endsum_I.f90 +estim.f90 estim_I.f90 +getaldwt.f90 getaldwt_I.f90 +getald.f90 getald_I.f90 +prtrsl.f90 prtrsl_I.f90 +getoldwt.f90 getoldwt_I.f90 +getold.f90 getold_I.f90 +getscd.f90 getscd_I.f90 +hmout.f90 hmout_I.f90 +out.f90 out_I.f90 +in.f90 in_I.f90 +prwf.f90 prwf_I.f90 +ispar.f90 ispar_I.f90 +itjpo.f90 itjpo_I.f90 +maneig.f90 maneig_I.f90 +matrix.f90 matrix_I.f90 +maxarr.f90 maxarr_I.f90 +newco.f90 newco_I.f90 +outbnd.f90 outbnd_I.f90 +newe.f90 newe_I.f90 +orbout.f90 orbout_I.f90 +orthor.f90 orthor_I.f90 +orthy.f90 orthy_I.f90 +solve.f90 solve_I.f90 +improv.f90 improv_I.f90 +scf.f90 scf_I.f90 +strsum.f90 strsum_I.f90 + +rscfvu.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rmcdhf90/CMakeLists.txt b/src/appl/rmcdhf90/CMakeLists.txt new file mode 100644 index 000000000..1acbd0e33 --- /dev/null +++ b/src/appl/rmcdhf90/CMakeLists.txt @@ -0,0 +1,114 @@ +add_executable(rmcdhf + mpi_s.f90 + dsubrs.f90 + dsubrs_I.f90 + fco.f90 + fco_I.f90 + gco.f90 + gco_I.f90 + setcof.f90 + setcof_I.f90 + lodcsh2GG.f90 + lodcsh2GG_I.f90 + setcsl.f90 + setcsl_I.f90 + setdbg.f90 + setdbg_I.f90 + setham.f90 + setham_I.f90 + xpot.f90 + xpot_I.f90 + ypot.f90 + ypot_I.f90 + dacon.f90 + dacon_I.f90 + dampck.f90 + dampck_I.f90 + setlag.f90 + setlag_I.f90 + setmcp.f90 + setmcp_I.f90 + setmix.f90 + setmix_I.f90 + setsum.f90 + setsum_I.f90 + setxuv.f90 + setxuv_I.f90 + setxv.f90 + setxv_I.f90 + setxz.f90 + setxz_I.f90 + lagcon.f90 + lagcon_I.f90 + cofpot.f90 + cofpot_I.f90 + consis.f90 + consis_I.f90 + csfwgt.f90 + csfwgt_I.f90 + dampor.f90 + dampor_I.f90 + defcor.f90 + defcor_I.f90 + eigen.f90 + eigen_I.f90 + engoutgg.f90 + engoutgg_I.f90 + endsum.f90 + endsum_I.f90 + estim.f90 + estim_I.f90 + getaldwt.f90 + getaldwt_I.f90 + getald.f90 + getald_I.f90 + prtrsl.f90 + prtrsl_I.f90 + getoldwt.f90 + getoldwt_I.f90 + getold.f90 + getold_I.f90 + getscd.f90 + getscd_I.f90 + hmout.f90 + hmout_I.f90 + out.f90 + out_I.f90 + in.f90 + in_I.f90 + prwf.f90 + prwf_I.f90 + ispar.f90 + ispar_I.f90 + itjpo.f90 + itjpo_I.f90 + maneig.f90 + maneig_I.f90 + matrix.f90 + matrix_I.f90 + maxarr.f90 + maxarr_I.f90 + newco.f90 + newco_I.f90 + outbnd.f90 + outbnd_I.f90 + newe.f90 + newe_I.f90 + orbout.f90 + orbout_I.f90 + orthor.f90 + orthor_I.f90 + orthy.f90 + orthy_I.f90 + solve.f90 + solve_I.f90 + improv.f90 + improv_I.f90 + scf.f90 + scf_I.f90 + strsum.f90 + strsum_I.f90 + rscfvu.f90 +) +target_link_libraries_Fortran(rmcdhf PUBLIC dvd90 9290 mod) +install(TARGETS rmcdhf DESTINATION bin/) diff --git a/src/appl/rmcdhf90/Makefile b/src/appl/rmcdhf90/Makefile index 294a911d9..3905eea42 100644 --- a/src/appl/rmcdhf90/Makefile +++ b/src/appl/rmcdhf90/Makefile @@ -1,49 +1,125 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rmcdhf +LIBS=-L ${GRASP}/lib/ -ldvd90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rmcdhf -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODDVD = ${SRCLIBDIR}/libdvd90 -GRASPLIBS =-l9290 -lmod -ldvd90 +OBJS= \ + mpi_s.o \ + dsubrs.o \ + dsubrs_I.o \ + fco.o \ + fco_I.o \ + gco.o \ + gco_I.o \ + setcof.o \ + setcof_I.o \ + lodcsh2GG.o \ + lodcsh2GG_I.o \ + setcsl.o \ + setcsl_I.o \ + setdbg.o \ + setdbg_I.o \ + setham.o \ + setham_I.o \ + xpot.o \ + xpot_I.o \ + ypot.o \ + ypot_I.o \ + dacon.o \ + dacon_I.o \ + dampck.o \ + dampck_I.o \ + setlag.o \ + setlag_I.o \ + setmcp.o \ + setmcp_I.o \ + setmix.o \ + setmix_I.o \ + setsum.o \ + setsum_I.o \ + setxuv.o \ + setxuv_I.o \ + setxv.o \ + setxv_I.o \ + setxz.o \ + setxz_I.o \ + lagcon.o \ + lagcon_I.o \ + cofpot.o \ + cofpot_I.o \ + consis.o \ + consis_I.o \ + csfwgt.o \ + csfwgt_I.o \ + dampor.o \ + dampor_I.o \ + defcor.o \ + defcor_I.o \ + eigen.o \ + eigen_I.o \ + engoutgg.o \ + engoutgg_I.o \ + endsum.o \ + endsum_I.o \ + estim.o \ + estim_I.o \ + getaldwt.o \ + getaldwt_I.o \ + getald.o \ + getald_I.o \ + prtrsl.o \ + prtrsl_I.o \ + getoldwt.o \ + getoldwt_I.o \ + getold.o \ + getold_I.o \ + getscd.o \ + getscd_I.o \ + hmout.o \ + hmout_I.o \ + out.o \ + out_I.o \ + in.o \ + in_I.o \ + prwf.o \ + prwf_I.o \ + ispar.o \ + ispar_I.o \ + itjpo.o \ + itjpo_I.o \ + maneig.o \ + maneig_I.o \ + matrix.o \ + matrix_I.o \ + maxarr.o \ + maxarr_I.o \ + newco.o \ + newco_I.o \ + outbnd.o \ + outbnd_I.o \ + newe.o \ + newe_I.o \ + orbout.o \ + orbout_I.o \ + orthor.o \ + orthor_I.o \ + orthy.o \ + orthy_I.o \ + solve.o \ + solve_I.o \ + improv.o \ + improv_I.o \ + scf.o \ + scf_I.o \ + strsum.o \ + strsum_I.o \ + rscfvu.o -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) - -APP_OBJ= mpi_s.o \ - itjpo_I.o ispar_I.o \ - dsubrs_I.o getaldwt_I.o orbout_I.o setcof_I.o setxuv_I.o\ - cofpot_I.o eigen_I.o getold_I.o orthor_I.o setcsl_I.o setxv_I.o\ - consis_I.o endsum_I.o getoldwt_I.o lagcon_I.o orthy_I.o setdbg_I.o setxz_I.o\ - csfwgt_I.o engoutgg_I.o getscd_I.o maneig_I.o out_I.o setham_I.o solve_I.o\ - dacon_I.o estim_I.o hmout_I.o matrix_I.o outbnd_I.o setlag_I.o strsum_I.o\ - dampck_I.o fco_I.o improv_I.o maxarr_I.o prtrsl_I.o setmcp_I.o xpot_I.o\ - dampor_I.o gco_I.o in_I.o newco_I.o prwf_I.o setmix_I.o ypot_I.o\ - defcor_I.o getald_I.o newe_I.o scf_I.o setsum_I.o lodcsh2GG_I.o \ - \ - itjpo.o ispar.o \ - rscfvu.o consis.o csfwgt.o dacon.o dampck.o dampor.o defcor.o \ - dsubrs.o eigen.o endsum.o engoutgg.o estim.o fco.o gco.o getaldwt.o \ - getoldwt.o in.o lagcon.o maxarr.o newe.o orbout.o \ - orthor.o orthy.o out.o outbnd.o prtrsl.o prwf.o setcof.o setdbg.o \ - setham.o setmcp.o setmix.o setsum.o setxuv.o setxv.o setxz.o solve.o \ - strsum.o xpot.o ypot.o \ - cofpot.o getald.o getold.o getscd.o hmout.o improv.o maneig.o \ - matrix.o newco.o scf.o setcsl.o setlag.o lodcsh2GG.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - ${LAPACK_LIBS} - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I ${MODDVD} \ - -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rmcdhf90_mpi/BUILDCONF.sh b/src/appl/rmcdhf90_mpi/BUILDCONF.sh new file mode 100644 index 000000000..b8c33c892 --- /dev/null +++ b/src/appl/rmcdhf90_mpi/BUILDCONF.sh @@ -0,0 +1,69 @@ +EXE=rmcdhf_mpi +LIBRARIES="dvd90 mpiu90 9290 mod" +LAPACK=true +ISMPI=true +FILES=" +dsubrs.f90 dsubrs_I.f90 +fco.f90 fco_I.f90 +gco.f90 gco_I.f90 +setcof.f90 setcof_I.f90 +xpot.f90 xpot_I.f90 +ypot.f90 ypot_I.f90 +lagcon.f90 lagcon_I.f90 +dacon.f90 dacon_I.f90 +cofpotmpi.f90 cofpotmpi_I.f90 +consis.f90 consis_I.f90 +csfwgt.f90 csfwgt_I.f90 +dampck.f90 dampck_I.f90 +dampor.f90 dampor_I.f90 +defcor.f90 defcor_I.f90 +eigen.f90 eigen_I.f90 +engoutgg.f90 engoutgg_I.f90 +endsum.f90 endsum_I.f90 +estim.f90 estim_I.f90 +getaldwt.f90 getaldwt_I.f90 +getaldmpi.f90 getaldmpi_I.f90 +prtrsl.f90 prtrsl_I.f90 +getoldwt.f90 getoldwt_I.f90 +getoldmpi.f90 getoldmpi_I.f90 +getscdmpi.f90 getscdmpi_I.f90 +hmoutmpi.f90 hmoutmpi_I.f90 +setxuv.f90 setxuv_I.f90 +setxv.f90 setxv_I.f90 +setxz.f90 setxz_I.f90 +out.f90 out_I.f90 +in.f90 in_I.f90 +prwf.f90 prwf_I.f90 +outbnd.f90 outbnd_I.f90 +newe.f90 newe_I.f90 +solve.f90 solve_I.f90 +setlagmpi.f90 setlagmpi_I.f90 +orthor.f90 orthor_I.f90 +orthy.f90 orthy_I.f90 +improvmpi.f90 improvmpi_I.f90 +ispar.f90 ispar_I.f90 +itjpo.f90 itjpo_I.f90 +lodcslmpiGG.f90 lodcslmpiGG_I.f90 +lodcsh2GG.f90 lodcsh2GG_I.f90 +maxarr.f90 maxarr_I.f90 +newcompi.f90 newcompi_I.f90 +orbout.f90 orbout_I.f90 +setcslmpi.f90 setcslmpi_I.f90 +setdbg.f90 setdbg_I.f90 +setdbgmpi.f90 setdbgmpi_I.f90 +setham.f90 setham_I.f90 +setmcp.f90 setmcp_I.f90 +setmix.f90 setmix_I.f90 +setsum.f90 setsum_I.f90 +strsum.f90 strsum_I.f90 +maneigmpi.f90 maneigmpi_I.f90 +matrixmpi.f90 matrixmpi_I.f90 +scfmpi.f90 scfmpi_I.f90 + +rscfmpivu.f90 + +# Note: the interfaces for hmoutmpi_I.f90, orthor_I.f90 and setdbg_I.f90 +# were not being linked in the original makefile. +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rmcdhf90_mpi/CMakeLists.txt b/src/appl/rmcdhf90_mpi/CMakeLists.txt new file mode 100644 index 000000000..76430cdaf --- /dev/null +++ b/src/appl/rmcdhf90_mpi/CMakeLists.txt @@ -0,0 +1,117 @@ +add_executable(rmcdhf_mpi + dsubrs.f90 + dsubrs_I.f90 + fco.f90 + fco_I.f90 + gco.f90 + gco_I.f90 + setcof.f90 + setcof_I.f90 + xpot.f90 + xpot_I.f90 + ypot.f90 + ypot_I.f90 + lagcon.f90 + lagcon_I.f90 + dacon.f90 + dacon_I.f90 + cofpotmpi.f90 + cofpotmpi_I.f90 + consis.f90 + consis_I.f90 + csfwgt.f90 + csfwgt_I.f90 + dampck.f90 + dampck_I.f90 + dampor.f90 + dampor_I.f90 + defcor.f90 + defcor_I.f90 + eigen.f90 + eigen_I.f90 + engoutgg.f90 + engoutgg_I.f90 + endsum.f90 + endsum_I.f90 + estim.f90 + estim_I.f90 + getaldwt.f90 + getaldwt_I.f90 + getaldmpi.f90 + getaldmpi_I.f90 + prtrsl.f90 + prtrsl_I.f90 + getoldwt.f90 + getoldwt_I.f90 + getoldmpi.f90 + getoldmpi_I.f90 + getscdmpi.f90 + getscdmpi_I.f90 + hmoutmpi.f90 + hmoutmpi_I.f90 + setxuv.f90 + setxuv_I.f90 + setxv.f90 + setxv_I.f90 + setxz.f90 + setxz_I.f90 + out.f90 + out_I.f90 + in.f90 + in_I.f90 + prwf.f90 + prwf_I.f90 + outbnd.f90 + outbnd_I.f90 + newe.f90 + newe_I.f90 + solve.f90 + solve_I.f90 + setlagmpi.f90 + setlagmpi_I.f90 + orthor.f90 + orthor_I.f90 + orthy.f90 + orthy_I.f90 + improvmpi.f90 + improvmpi_I.f90 + ispar.f90 + ispar_I.f90 + itjpo.f90 + itjpo_I.f90 + lodcslmpiGG.f90 + lodcslmpiGG_I.f90 + lodcsh2GG.f90 + lodcsh2GG_I.f90 + maxarr.f90 + maxarr_I.f90 + newcompi.f90 + newcompi_I.f90 + orbout.f90 + orbout_I.f90 + setcslmpi.f90 + setcslmpi_I.f90 + setdbg.f90 + setdbg_I.f90 + setdbgmpi.f90 + setdbgmpi_I.f90 + setham.f90 + setham_I.f90 + setmcp.f90 + setmcp_I.f90 + setmix.f90 + setmix_I.f90 + setsum.f90 + setsum_I.f90 + strsum.f90 + strsum_I.f90 + maneigmpi.f90 + maneigmpi_I.f90 + matrixmpi.f90 + matrixmpi_I.f90 + scfmpi.f90 + scfmpi_I.f90 + rscfmpivu.f90 +) +target_link_libraries_Fortran(rmcdhf_mpi PUBLIC dvd90 mpiu90 9290 mod) +install(TARGETS rmcdhf_mpi DESTINATION bin/) diff --git a/src/appl/rmcdhf90_mpi/Makefile b/src/appl/rmcdhf90_mpi/Makefile index 2e168cd6e..6c4373ad1 100644 --- a/src/appl/rmcdhf90_mpi/Makefile +++ b/src/appl/rmcdhf90_mpi/Makefile @@ -1,58 +1,128 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rmcdhf_mpi +LIBS=-L ${GRASP}/lib/ -ldvd90 -lmpiu90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/mpi90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rmcdhf_mpi -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODDVD = ${SRCLIBDIR}/libdvd90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lmcp90 -lmpiu90 -ldvd90 -LAPACK90_LIB = -llapack -lblas +OBJS= \ + dsubrs.o \ + dsubrs_I.o \ + fco.o \ + fco_I.o \ + gco.o \ + gco_I.o \ + setcof.o \ + setcof_I.o \ + xpot.o \ + xpot_I.o \ + ypot.o \ + ypot_I.o \ + lagcon.o \ + lagcon_I.o \ + dacon.o \ + dacon_I.o \ + cofpotmpi.o \ + cofpotmpi_I.o \ + consis.o \ + consis_I.o \ + csfwgt.o \ + csfwgt_I.o \ + dampck.o \ + dampck_I.o \ + dampor.o \ + dampor_I.o \ + defcor.o \ + defcor_I.o \ + eigen.o \ + eigen_I.o \ + engoutgg.o \ + engoutgg_I.o \ + endsum.o \ + endsum_I.o \ + estim.o \ + estim_I.o \ + getaldwt.o \ + getaldwt_I.o \ + getaldmpi.o \ + getaldmpi_I.o \ + prtrsl.o \ + prtrsl_I.o \ + getoldwt.o \ + getoldwt_I.o \ + getoldmpi.o \ + getoldmpi_I.o \ + getscdmpi.o \ + getscdmpi_I.o \ + hmoutmpi.o \ + hmoutmpi_I.o \ + setxuv.o \ + setxuv_I.o \ + setxv.o \ + setxv_I.o \ + setxz.o \ + setxz_I.o \ + out.o \ + out_I.o \ + in.o \ + in_I.o \ + prwf.o \ + prwf_I.o \ + outbnd.o \ + outbnd_I.o \ + newe.o \ + newe_I.o \ + solve.o \ + solve_I.o \ + setlagmpi.o \ + setlagmpi_I.o \ + orthor.o \ + orthor_I.o \ + orthy.o \ + orthy_I.o \ + improvmpi.o \ + improvmpi_I.o \ + ispar.o \ + ispar_I.o \ + itjpo.o \ + itjpo_I.o \ + lodcslmpiGG.o \ + lodcslmpiGG_I.o \ + lodcsh2GG.o \ + lodcsh2GG_I.o \ + maxarr.o \ + maxarr_I.o \ + newcompi.o \ + newcompi_I.o \ + orbout.o \ + orbout_I.o \ + setcslmpi.o \ + setcslmpi_I.o \ + setdbg.o \ + setdbg_I.o \ + setdbgmpi.o \ + setdbgmpi_I.o \ + setham.o \ + setham_I.o \ + setmcp.o \ + setmcp_I.o \ + setmix.o \ + setmix_I.o \ + setsum.o \ + setsum_I.o \ + strsum.o \ + strsum_I.o \ + maneigmpi.o \ + maneigmpi_I.o \ + matrixmpi.o \ + matrixmpi_I.o \ + scfmpi.o \ + scfmpi_I.o \ + rscfmpivu.o -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC_MPI) -o $@ $? $(FC_MPILD) $(LIBS) $(LAPACK_LIBS) -# Define data types -VASTO = ${MODDIR}/vast_kind_param_M.o - -APP_OBJ= \ - consis_I.o csfwgt_I.o dacon_I.o dampck_I.o dampor_I.o defcor_I.o \ - dsubrs_I.o eigen_I.o endsum_I.o engoutgg_I.o estim_I.o fco_I.o gco_I.o getaldwt_I.o \ - getoldwt_I.o in_I.o lagcon_I.o maxarr_I.o \ - newe_I.o orbout_I.o \ - orthy_I.o \ - out_I.o outbnd_I.o prtrsl_I.o prwf_I.o setcof_I.o \ - setham_I.o setmcp_I.o setmix_I.o setsum_I.o setxuv_I.o setxv_I.o setxz_I.o solve_I.o \ - strsum_I.o xpot_I.o ypot_I.o \ - cofpotmpi_I.o getaldmpi_I.o getoldmpi_I.o getscdmpi_I.o \ - maneigmpi_I.o matrixmpi_I.o newcompi_I.o \ - improvmpi_I.o \ - scfmpi_I.o itjpo_I.o ispar_I.o\ - setcslmpi_I.o setdbgmpi_I.o setlagmpi_I.o lodcsh2GG_I.o lodcslmpiGG_I.o \ - \ - consis.o csfwgt.o dacon.o dampck.o dampor.o defcor.o \ - dsubrs.o eigen.o endsum.o engoutgg.o estim.o fco.o gco.o getaldwt.o \ - getoldwt.o in.o lagcon.o maxarr.o newe.o orbout.o \ - orthor.o orthy.o out.o outbnd.o prtrsl.o prwf.o setcof.o setdbg.o \ - setham.o setmcp.o setmix.o setsum.o setxuv.o setxv.o setxz.o solve.o \ - strsum.o xpot.o ypot.o \ - cofpotmpi.o getaldmpi.o getoldmpi.o getscdmpi.o hmoutmpi.o \ - improvmpi.o maneigmpi.o matrixmpi.o newcompi.o rscfmpivu.o scfmpi.o \ - setcslmpi.o setdbgmpi.o setlagmpi.o lodcsh2GG.o lodcslmpiGG.o itjpo.o ispar.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLMPIU90) -I ${MODDVD} \ - -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rnucleus90/BUILDCONF.sh b/src/appl/rnucleus90/BUILDCONF.sh new file mode 100644 index 000000000..d26b267d8 --- /dev/null +++ b/src/appl/rnucleus90/BUILDCONF.sh @@ -0,0 +1,10 @@ +EXE=rnucleus +LIBRARIES="9290 mod" +FILES=" +skfun.f90 skfun_I.f90 +estrms.f90 estrms_I.f90 +getcpr.f90 getcpr_I.f90 +geniso.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rnucleus90/CMakeLists.txt b/src/appl/rnucleus90/CMakeLists.txt new file mode 100644 index 000000000..f8efcab74 --- /dev/null +++ b/src/appl/rnucleus90/CMakeLists.txt @@ -0,0 +1,11 @@ +add_executable(rnucleus + skfun.f90 + skfun_I.f90 + estrms.f90 + estrms_I.f90 + getcpr.f90 + getcpr_I.f90 + geniso.f90 +) +target_link_libraries_Fortran(rnucleus PUBLIC 9290 mod) +install(TARGETS rnucleus DESTINATION bin/) diff --git a/src/appl/rnucleus90/Makefile b/src/appl/rnucleus90/Makefile index 3f7ee1147..2087425b3 100644 --- a/src/appl/rnucleus90/Makefile +++ b/src/appl/rnucleus90/Makefile @@ -1,27 +1,22 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rnucleus +LIBS=-L ${GRASP}/lib/ -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rnucleus -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -GRASPLIBS =-l9290 -lmod - -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} - -APP_OBJ= \ - estrms_I.o getcpr_I.o skfun_I.o \ - estrms.o geniso.o getcpr.o skfun.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(iFC_LD) $(APP_OBJ) $(APP_LIBS) - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL9290} -o $@ +OBJS= \ + skfun.o \ + skfun_I.o \ + estrms.o \ + estrms_I.o \ + getcpr.o \ + getcpr_I.o \ + geniso.o +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rtransition90/BUILDCONF.sh b/src/appl/rtransition90/BUILDCONF.sh new file mode 100644 index 000000000..773820863 --- /dev/null +++ b/src/appl/rtransition90/BUILDCONF.sh @@ -0,0 +1,51 @@ +EXE=rtransition +LIBRARIES="dvd90 rang90 mcp90 9290 mod" +LAPACK=true +FILES=" +alclla.f90 alclla_I.f90 +alcnma.f90 alcnma_I.f90 +alcnsa.f90 alcnsa_I.f90 +alcnta.f90 alcnta_I.f90 +angdata.f90 angdata_I.f90 +bessj.f90 bessj_I.f90 +brkt.f90 brkt_I.f90 +connect.f90 connect_I.f90 +cpmix.f90 cpmix_I.f90 +spme.f90 spme_I.f90 +csfm.f90 csfm_I.f90 +engout1.f90 engout1_I.f90 +fname.f90 fname_I.f90 +lodrwff.f90 lodrwff_I.f90 +lodrwfi.f90 lodrwfi_I.f90 +getrmp.f90 getrmp_I.f90 +getosd.f90 getosd_I.f90 +iqr.f90 iqr_I.f90 +isparr.f90 isparr_I.f90 +itjpor.f90 itjpor_I.f90 +jcupr.f90 jcupr_I.f90 +jqsr.f90 jqsr_I.f90 +ldcsl1.f90 ldcsl1_I.f90 +ldcsl2.f90 ldcsl2_I.f90 +ldlbl1.f90 ldlbl1_I.f90 +ldlbl2.f90 ldlbl2_I.f90 +lodcslm.f90 lodcslm_I.f90 +mctin.f90 mctin_I.f90 +trsort.f90 trsort_I.f90 +mctout_gg.f90 mctout_gg_I.f90 +merg12.f90 merg12_I.f90 +mrgcsl.f90 mrgcsl_I.f90 +readmix.f90 readmix_I.f90 +printaLS.f90 printaLS_I.f90 +printa.f90 printa_I.f90 +oscl.f90 oscl_I.f90 +setcslm.f90 setcslm_I.f90 +strsum.f90 strsum_I.f90 +testmix.f90 testmix_I.f90 +bioscl.f90 + +# Implementation not compiled in the original makefile +#ichkq1.f90 ichkq1_I.f90 +#setcsl.f90 setcsl_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rtransition90/CMakeLists.txt b/src/appl/rtransition90/CMakeLists.txt new file mode 100644 index 000000000..cca7110f8 --- /dev/null +++ b/src/appl/rtransition90/CMakeLists.txt @@ -0,0 +1,83 @@ +add_executable(rtransition + alclla.f90 + alclla_I.f90 + alcnma.f90 + alcnma_I.f90 + alcnsa.f90 + alcnsa_I.f90 + alcnta.f90 + alcnta_I.f90 + angdata.f90 + angdata_I.f90 + bessj.f90 + bessj_I.f90 + brkt.f90 + brkt_I.f90 + connect.f90 + connect_I.f90 + cpmix.f90 + cpmix_I.f90 + spme.f90 + spme_I.f90 + csfm.f90 + csfm_I.f90 + engout1.f90 + engout1_I.f90 + fname.f90 + fname_I.f90 + lodrwff.f90 + lodrwff_I.f90 + lodrwfi.f90 + lodrwfi_I.f90 + getrmp.f90 + getrmp_I.f90 + getosd.f90 + getosd_I.f90 + iqr.f90 + iqr_I.f90 + isparr.f90 + isparr_I.f90 + itjpor.f90 + itjpor_I.f90 + jcupr.f90 + jcupr_I.f90 + jqsr.f90 + jqsr_I.f90 + ldcsl1.f90 + ldcsl1_I.f90 + ldcsl2.f90 + ldcsl2_I.f90 + ldlbl1.f90 + ldlbl1_I.f90 + ldlbl2.f90 + ldlbl2_I.f90 + lodcslm.f90 + lodcslm_I.f90 + mctin.f90 + mctin_I.f90 + trsort.f90 + trsort_I.f90 + mctout_gg.f90 + mctout_gg_I.f90 + merg12.f90 + merg12_I.f90 + mrgcsl.f90 + mrgcsl_I.f90 + readmix.f90 + readmix_I.f90 + printaLS.f90 + printaLS_I.f90 + printa.f90 + printa_I.f90 + oscl.f90 + oscl_I.f90 + setcslm.f90 + setcslm_I.f90 + strsum.f90 + strsum_I.f90 + testmix.f90 + testmix_I.f90 + bioscl.f90 +) +target_link_libraries_Fortran(rtransition PUBLIC dvd90 rang90 mcp90 9290 mod) +install(TARGETS rtransition DESTINATION bin/) diff --git a/src/appl/rtransition90/Makefile b/src/appl/rtransition90/Makefile index 463c47981..fd1f8f508 100644 --- a/src/appl/rtransition90/Makefile +++ b/src/appl/rtransition90/Makefile @@ -1,46 +1,94 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rtransition +LIBS=-L ${GRASP}/lib/ -ldvd90 -lrang90 -lmcp90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rtransition -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 +OBJS= \ + alclla.o \ + alclla_I.o \ + alcnma.o \ + alcnma_I.o \ + alcnsa.o \ + alcnsa_I.o \ + alcnta.o \ + alcnta_I.o \ + angdata.o \ + angdata_I.o \ + bessj.o \ + bessj_I.o \ + brkt.o \ + brkt_I.o \ + connect.o \ + connect_I.o \ + cpmix.o \ + cpmix_I.o \ + spme.o \ + spme_I.o \ + csfm.o \ + csfm_I.o \ + engout1.o \ + engout1_I.o \ + fname.o \ + fname_I.o \ + lodrwff.o \ + lodrwff_I.o \ + lodrwfi.o \ + lodrwfi_I.o \ + getrmp.o \ + getrmp_I.o \ + getosd.o \ + getosd_I.o \ + iqr.o \ + iqr_I.o \ + isparr.o \ + isparr_I.o \ + itjpor.o \ + itjpor_I.o \ + jcupr.o \ + jcupr_I.o \ + jqsr.o \ + jqsr_I.o \ + ldcsl1.o \ + ldcsl1_I.o \ + ldcsl2.o \ + ldcsl2_I.o \ + ldlbl1.o \ + ldlbl1_I.o \ + ldlbl2.o \ + ldlbl2_I.o \ + lodcslm.o \ + lodcslm_I.o \ + mctin.o \ + mctin_I.o \ + trsort.o \ + trsort_I.o \ + mctout_gg.o \ + mctout_gg_I.o \ + merg12.o \ + merg12_I.o \ + mrgcsl.o \ + mrgcsl_I.o \ + readmix.o \ + readmix_I.o \ + printaLS.o \ + printaLS_I.o \ + printa.o \ + printa_I.o \ + oscl.o \ + oscl_I.o \ + setcslm.o \ + setcslm_I.o \ + strsum.o \ + strsum_I.o \ + testmix.o \ + testmix_I.o \ + bioscl.o -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -APP_OBJ= \ - alclla_I.o cpmix_I.o itjpor_I.o mctout_gg_I.o spme_I.o\ - alcnma_I.o engout1_I.o jcupr_I.o merg12_I.o strsum_I.o\ - alcnsa_I.o fname_I.o jqsr_I.o mrgcsl_I.o testmix_I.o\ - alcnta_I.o getosd_I.o ldcsl2_I.o oscl_I.o trsort_I.o\ - angdata_I.o getrmp_I.o lodcslm_I.o printa_I.o ldcsl1_I.o \ - bessj_I.o ichkq1_I.o lodrwff_I.o readmix_I.o csfm_I.o\ - brkt_I.o iqr_I.o lodrwfi_I.o setcsl_I.o\ - connect_I.o isparr_I.o mctin_I.o setcslm_I.o\ - ldlbl1_I.o ldlbl2_I.o printaLS_I.o\ -\ - bioscl.o fname.o ldcsl1.o ldcsl2.o lodcslm.o merg12.o mrgcsl.o \ - readmix.o iqr.o isparr.o itjpor.o jcupr.o jqsr.o lodrwfi.o \ - lodrwff.o getosd.o brkt.o getrmp.o strsum.o oscl.o connect.o \ - alcnsa.o alcnta.o mctin.o csfm.o printa.o spme.o testmix.o trsort.o \ - bessj.o alclla.o alcnma.o setcslm.o angdata.o engout1.o mctout_gg.o \ - cpmix.o \ - ldlbl1.o ldlbl2.o printaLS.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -o $@ - -.f.o: - $(F90) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rtransition90_mpi/BUILDCONF.sh b/src/appl/rtransition90_mpi/BUILDCONF.sh new file mode 100644 index 000000000..1bbeaad85 --- /dev/null +++ b/src/appl/rtransition90_mpi/BUILDCONF.sh @@ -0,0 +1,51 @@ +EXE=rtransition_mpi +LIBRARIES="mcp90 dvd90 rang90 mpiu90 9290 mod" +LAPACK=true +ISMPI=true +FILES=" +alclla.f90 alclla_I.f90 +alcnma.f90 alcnma_I.f90 +alcnsa.f90 alcnsa_I.f90 +alcnta.f90 alcnta_I.f90 +angdatampi.f90 angdatampi_I.f90 +bessj.f90 bessj_I.f90 +brkt.f90 brkt_I.f90 +connect.f90 connect_I.f90 +cpmix.f90 cpmix_I.f90 +spme.f90 spme_I.f90 +csfm.f90 csfm_I.f90 +engout1.f90 engout1_I.f90 +fname.f90 fname_I.f90 +getrmpmpi.f90 getrmpmpi_I.f90 +lodrwffmpi.f90 lodrwffmpi_I.f90 +lodrwfimpi.f90 lodrwfimpi_I.f90 +getosdmpi.f90 getosdmpi_I.f90 +iqr.f90 iqr_I.f90 +isparr.f90 isparr_I.f90 +itjpor.f90 itjpor_I.f90 +jcupr.f90 jcupr_I.f90 +jqsr.f90 jqsr_I.f90 +ldcsl1mpi.f90 ldcsl1mpi_I.f90 +ldcsl2mpi.f90 ldcsl2mpi_I.f90 +ldlbl1.f90 ldlbl1_I.f90 +ldlbl2.f90 ldlbl2_I.f90 +lodcslm.f90 lodcslm_I.f90 +trsortmpi.f90 trsortmpi_I.f90 +mctinmpi.f90 mctinmpi_I.f90 +mctoutmpi_gg.f90 mctoutmpi_gg_I.f90 +merg12mpi.f90 merg12mpi_I.f90 +mrgcslmpi.f90 mrgcslmpi_I.f90 +readmixmpi.f90 readmixmpi_I.f90 +printaLS.f90 printaLS_I.f90 +printa.f90 printa_I.f90 +osclmpi.f90 osclmpi_I.f90 +setcslm.f90 setcslm_I.f90 +strsum.f90 strsum_I.f90 +testmix.f90 testmix_I.f90 +biosclmpi.f90 + +# Not referenced in the original makefile +#setcsl.f90 setcsl_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rtransition90_mpi/CMakeLists.txt b/src/appl/rtransition90_mpi/CMakeLists.txt new file mode 100644 index 000000000..099c4dffd --- /dev/null +++ b/src/appl/rtransition90_mpi/CMakeLists.txt @@ -0,0 +1,83 @@ +add_executable(rtransition_mpi + alclla.f90 + alclla_I.f90 + alcnma.f90 + alcnma_I.f90 + alcnsa.f90 + alcnsa_I.f90 + alcnta.f90 + alcnta_I.f90 + angdatampi.f90 + angdatampi_I.f90 + bessj.f90 + bessj_I.f90 + brkt.f90 + brkt_I.f90 + connect.f90 + connect_I.f90 + cpmix.f90 + cpmix_I.f90 + spme.f90 + spme_I.f90 + csfm.f90 + csfm_I.f90 + engout1.f90 + engout1_I.f90 + fname.f90 + fname_I.f90 + getrmpmpi.f90 + getrmpmpi_I.f90 + lodrwffmpi.f90 + lodrwffmpi_I.f90 + lodrwfimpi.f90 + lodrwfimpi_I.f90 + getosdmpi.f90 + getosdmpi_I.f90 + iqr.f90 + iqr_I.f90 + isparr.f90 + isparr_I.f90 + itjpor.f90 + itjpor_I.f90 + jcupr.f90 + jcupr_I.f90 + jqsr.f90 + jqsr_I.f90 + ldcsl1mpi.f90 + ldcsl1mpi_I.f90 + ldcsl2mpi.f90 + ldcsl2mpi_I.f90 + ldlbl1.f90 + ldlbl1_I.f90 + ldlbl2.f90 + ldlbl2_I.f90 + lodcslm.f90 + lodcslm_I.f90 + trsortmpi.f90 + trsortmpi_I.f90 + mctinmpi.f90 + mctinmpi_I.f90 + mctoutmpi_gg.f90 + mctoutmpi_gg_I.f90 + merg12mpi.f90 + merg12mpi_I.f90 + mrgcslmpi.f90 + mrgcslmpi_I.f90 + readmixmpi.f90 + readmixmpi_I.f90 + printaLS.f90 + printaLS_I.f90 + printa.f90 + printa_I.f90 + osclmpi.f90 + osclmpi_I.f90 + setcslm.f90 + setcslm_I.f90 + strsum.f90 + strsum_I.f90 + testmix.f90 + testmix_I.f90 + biosclmpi.f90 +) +target_link_libraries_Fortran(rtransition_mpi PUBLIC mcp90 dvd90 rang90 mpiu90 9290 mod) +install(TARGETS rtransition_mpi DESTINATION bin/) diff --git a/src/appl/rtransition90_mpi/Makefile b/src/appl/rtransition90_mpi/Makefile index 333eeb96b..1f9213ba1 100644 --- a/src/appl/rtransition90_mpi/Makefile +++ b/src/appl/rtransition90_mpi/Makefile @@ -1,46 +1,94 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rtransition_mpi +LIBS=-L ${GRASP}/lib/ -lmcp90 -ldvd90 -lrang90 -lmpiu90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/libdvd90 -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/mpi90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rtransition_mpi -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -MODLMPIU90 = ${SRCLIBDIR}/mpi90 +OBJS= \ + alclla.o \ + alclla_I.o \ + alcnma.o \ + alcnma_I.o \ + alcnsa.o \ + alcnsa_I.o \ + alcnta.o \ + alcnta_I.o \ + angdatampi.o \ + angdatampi_I.o \ + bessj.o \ + bessj_I.o \ + brkt.o \ + brkt_I.o \ + connect.o \ + connect_I.o \ + cpmix.o \ + cpmix_I.o \ + spme.o \ + spme_I.o \ + csfm.o \ + csfm_I.o \ + engout1.o \ + engout1_I.o \ + fname.o \ + fname_I.o \ + getrmpmpi.o \ + getrmpmpi_I.o \ + lodrwffmpi.o \ + lodrwffmpi_I.o \ + lodrwfimpi.o \ + lodrwfimpi_I.o \ + getosdmpi.o \ + getosdmpi_I.o \ + iqr.o \ + iqr_I.o \ + isparr.o \ + isparr_I.o \ + itjpor.o \ + itjpor_I.o \ + jcupr.o \ + jcupr_I.o \ + jqsr.o \ + jqsr_I.o \ + ldcsl1mpi.o \ + ldcsl1mpi_I.o \ + ldcsl2mpi.o \ + ldcsl2mpi_I.o \ + ldlbl1.o \ + ldlbl1_I.o \ + ldlbl2.o \ + ldlbl2_I.o \ + lodcslm.o \ + lodcslm_I.o \ + trsortmpi.o \ + trsortmpi_I.o \ + mctinmpi.o \ + mctinmpi_I.o \ + mctoutmpi_gg.o \ + mctoutmpi_gg_I.o \ + merg12mpi.o \ + merg12mpi_I.o \ + mrgcslmpi.o \ + mrgcslmpi_I.o \ + readmixmpi.o \ + readmixmpi_I.o \ + printaLS.o \ + printaLS_I.o \ + printa.o \ + printa_I.o \ + osclmpi.o \ + osclmpi_I.o \ + setcslm.o \ + setcslm_I.o \ + strsum.o \ + strsum_I.o \ + testmix.o \ + testmix_I.o \ + biosclmpi.o -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 -ldvd90 -lmpiu90 +$(EXE): $(OBJS) + $(FC_MPI) -o $@ $? $(FC_MPILD) $(LIBS) $(LAPACK_LIBS) -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} - -APP_OBJ= \ - fname_I.o ldcsl1mpi_I.o ldcsl2mpi_I.o lodcslm_I.o \ - merg12mpi_I.o mrgcslmpi_I.o ldlbl1_I.o ldlbl2_I.o printaLS_I.o \ - readmixmpi_I.o iqr_I.o isparr_I.o itjpor_I.o jcupr_I.o jqsr_I.o lodrwfimpi_I.o \ - lodrwffmpi_I.o getosdmpi_I.o brkt_I.o getrmpmpi_I.o strsum_I.o osclmpi_I.o \ - connect_I.o cpmix_I.o mctoutmpi_gg_I.o\ - alcnsa_I.o alcnta_I.o mctinmpi_I.o csfm_I.o printa_I.o spme_I.o trsortmpi_I.o \ - bessj_I.o alclla_I.o alcnma_I.o setcslm_I.o angdatampi_I.o engout1_I.o testmix_I.o \ - \ - biosclmpi.o fname.o ldcsl1mpi.o ldcsl2mpi.o lodcslm.o \ - merg12mpi.o mrgcslmpi.o ldlbl1.o ldlbl2.o printaLS.o \ - readmixmpi.o iqr.o isparr.o itjpor.o jcupr.o jqsr.o lodrwfimpi.o \ - lodrwffmpi.o getosdmpi.o brkt.o getrmpmpi.o strsum.o osclmpi.o \ - connect.o cpmix.o mctoutmpi_gg.o\ - alcnsa.o alcnta.o mctinmpi.o csfm.o printa.o spme.o trsortmpi.o \ - bessj.o alclla.o alcnma.o setcslm.o angdatampi.o engout1.o testmix.o - -$(EXE): $(APP_OBJ) - $(FC_MPI) -o $(BINFILE) $(FC_MPILD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I . -I ${MODL92} -I ${MODLRANG90} -I $(MODLMCP90) -I $(MODLMPIU90) -o $@ - -.f.o: - $(FC_MPI) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/rwfnestimate90/BUILDCONF.sh b/src/appl/rwfnestimate90/BUILDCONF.sh new file mode 100644 index 000000000..104bb40b4 --- /dev/null +++ b/src/appl/rwfnestimate90/BUILDCONF.sh @@ -0,0 +1,24 @@ +EXE=rwfnestimate +LIBRARIES="rang90 9290 mod" +LAPACK=true +FILES=" +tail.f90 tail_I.f90 +sbstep.f90 sbstep_I.f90 +solvh.f90 solvh_I.f90 +frmhyd.f90 frmhyd_I.f90 +frmrwf.f90 frmrwf_I.f90 +frmtfp.f90 frmtfp_I.f90 +tfpot.f90 tfpot_I.f90 +prtrem.f90 prtrem_I.f90 +screenpar.f90 screenpar_I.f90 +setdbg.f90 setdbg_I.f90 +setsum.f90 setsum_I.f90 +strsum.f90 strsum_I.f90 +summry.f90 summry_I.f90 +wrtrwf.f90 wrtrwf_I.f90 +genrwf.f90 genrwf_I.f90 +getinfo.f90 getinf_I.f90 # subroutine GETINF, implementation in getinfo.f90 +erwf.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/rwfnestimate90/CMakeLists.txt b/src/appl/rwfnestimate90/CMakeLists.txt new file mode 100644 index 000000000..6a8a813a0 --- /dev/null +++ b/src/appl/rwfnestimate90/CMakeLists.txt @@ -0,0 +1,37 @@ +add_executable(rwfnestimate + tail.f90 + tail_I.f90 + sbstep.f90 + sbstep_I.f90 + solvh.f90 + solvh_I.f90 + frmhyd.f90 + frmhyd_I.f90 + frmrwf.f90 + frmrwf_I.f90 + frmtfp.f90 + frmtfp_I.f90 + tfpot.f90 + tfpot_I.f90 + prtrem.f90 + prtrem_I.f90 + screenpar.f90 + screenpar_I.f90 + setdbg.f90 + setdbg_I.f90 + setsum.f90 + setsum_I.f90 + strsum.f90 + strsum_I.f90 + summry.f90 + summry_I.f90 + wrtrwf.f90 + wrtrwf_I.f90 + genrwf.f90 + genrwf_I.f90 + getinfo.f90 + getinf_I.f90 + erwf.f90 +) +target_link_libraries_Fortran(rwfnestimate PUBLIC rang90 9290 mod) +install(TARGETS rwfnestimate DESTINATION bin/) diff --git a/src/appl/rwfnestimate90/Makefile b/src/appl/rwfnestimate90/Makefile index 996894192..eee32b691 100644 --- a/src/appl/rwfnestimate90/Makefile +++ b/src/appl/rwfnestimate90/Makefile @@ -1,37 +1,48 @@ - -.SUFFIXES: .f90 .mod - -EXE = rwfnestimate -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -GRASPLIBS = -l9290 -lmod -lrang90 - -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} -llapack -lblas - -APP_OBJ = \ -genrwf_I.o screenpar_I.o strsum_I.o wrtrwf_I.o \ -frmhyd_I.o getinf_I.o setdbg_I.o summry_I.o frmrwf_I.o prtrem_I.o \ -setsum_I.o tail_I.o frmtfp_I.o sbstep_I.o solvh_I.o tfpot_I.o \ - \ - erwf.o frmhyd.o frmrwf.o frmtfp.o genrwf.o \ -getinfo.o prtrem.o sbstep.o screenpar.o setdbg.o setsum.o \ -solvh.o strsum.o summry.o tail.o tfpot.o wrtrwf.o - -$(EXE): ${APP_IOBJ} $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) ${LAPACK_LIBS} - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -I ${MODL9290} \ - -I ${MODLRANG90} -o $@ - - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +EXE=${GRASP}/bin/rwfnestimate +LIBS=-L ${GRASP}/lib/ -lrang90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod + +OBJS= \ + tail.o \ + tail_I.o \ + sbstep.o \ + sbstep_I.o \ + solvh.o \ + solvh_I.o \ + frmhyd.o \ + frmhyd_I.o \ + frmrwf.o \ + frmrwf_I.o \ + frmtfp.o \ + frmtfp_I.o \ + tfpot.o \ + tfpot_I.o \ + prtrem.o \ + prtrem_I.o \ + screenpar.o \ + screenpar_I.o \ + setdbg.o \ + setdbg_I.o \ + setsum.o \ + setsum_I.o \ + strsum.o \ + strsum_I.o \ + summry.o \ + summry_I.o \ + wrtrwf.o \ + wrtrwf_I.o \ + genrwf.o \ + genrwf_I.o \ + getinfo.o \ + getinf_I.o \ + erwf.o + +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) + +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/appl/sms90/BUILDCONF.sh b/src/appl/sms90/BUILDCONF.sh new file mode 100644 index 000000000..9c27315ba --- /dev/null +++ b/src/appl/sms90/BUILDCONF.sh @@ -0,0 +1,30 @@ +EXE=rsms +LIBRARIES="rang90 mcp90 9290 mod" +LAPACK=true +FILES=" +dvpot_C.f90 +sms1_C.f90 +teilst_C.f90 + +densmcp.f90 densmcp_I.f90 +densnew.f90 densnew_I.f90 +engout.f90 engout_I.f90 +gco.f90 gco_I.f90 +getmixblock.f90 getmixblock_I.f90 +getsmd.f90 getsmd_I.f90 +polint.f90 polint_I.f90 +rintdens.f90 rintdens_I.f90 +rintiso.f90 rintiso_I.f90 +setdbg.f90 setdbg_I.f90 +setmcp.f90 setmcp_I.f90 +setsum.f90 setsum_I.f90 +wghtd5.f90 wghtd5_I.f90 +strsum.f90 strsum_I.f90 +vinti.f90 vinti_I.f90 +smsmcp.f90 smsmcp_I.f90 +smsnew.f90 smsnew_I.f90 +sms.f90 sms_I.f90 +sms92.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/appl/sms90/CMakeLists.txt b/src/appl/sms90/CMakeLists.txt new file mode 100644 index 000000000..ab78e7ecc --- /dev/null +++ b/src/appl/sms90/CMakeLists.txt @@ -0,0 +1,44 @@ +add_executable(rsms + dvpot_C.f90 + sms1_C.f90 + teilst_C.f90 + densmcp.f90 + densmcp_I.f90 + densnew.f90 + densnew_I.f90 + engout.f90 + engout_I.f90 + gco.f90 + gco_I.f90 + getmixblock.f90 + getmixblock_I.f90 + getsmd.f90 + getsmd_I.f90 + polint.f90 + polint_I.f90 + rintdens.f90 + rintdens_I.f90 + rintiso.f90 + rintiso_I.f90 + setdbg.f90 + setdbg_I.f90 + setmcp.f90 + setmcp_I.f90 + setsum.f90 + setsum_I.f90 + wghtd5.f90 + wghtd5_I.f90 + strsum.f90 + strsum_I.f90 + vinti.f90 + vinti_I.f90 + smsmcp.f90 + smsmcp_I.f90 + smsnew.f90 + smsnew_I.f90 + sms.f90 + sms_I.f90 + sms92.f90 +) +target_link_libraries_Fortran(rsms PUBLIC rang90 mcp90 9290 mod) +install(TARGETS rsms DESTINATION bin/) diff --git a/src/appl/sms90/Makefile b/src/appl/sms90/Makefile index bec9c4c53..bf36c1104 100644 --- a/src/appl/sms90/Makefile +++ b/src/appl/sms90/Makefile @@ -1,40 +1,55 @@ -.SUFFIXES: .f90 .mod +EXE=${GRASP}/bin/rsms +LIBS=-L ${GRASP}/lib/ -lrang90 -lmcp90 -l9290 -lmod +FC_MODULES= -I ${GRASP}/src/lib/librang90 -I ${GRASP}/src/lib/libmcp90 -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -EXE = rsms -BINDIR = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -BINFILE = $(BINDIR)/$(EXE) -SRCLIBDIR = ../../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL92 = ${SRCLIBDIR}/lib9290 -MODLRANG90 = ${SRCLIBDIR}/librang90 -MODLMCP90 = ${SRCLIBDIR}/libmcp90 -GRASPLIBS =-l9290 -lmod -lrang90 -lmcp90 +OBJS= \ + dvpot_C.o \ + sms1_C.o \ + teilst_C.o \ + densmcp.o \ + densmcp_I.o \ + densnew.o \ + densnew_I.o \ + engout.o \ + engout_I.o \ + gco.o \ + gco_I.o \ + getmixblock.o \ + getmixblock_I.o \ + getsmd.o \ + getsmd_I.o \ + polint.o \ + polint_I.o \ + rintdens.o \ + rintdens_I.o \ + rintiso.o \ + rintiso_I.o \ + setdbg.o \ + setdbg_I.o \ + setmcp.o \ + setmcp_I.o \ + setsum.o \ + setsum_I.o \ + wghtd5.o \ + wghtd5_I.o \ + strsum.o \ + strsum_I.o \ + vinti.o \ + vinti_I.o \ + smsmcp.o \ + smsmcp_I.o \ + smsnew.o \ + smsnew_I.o \ + sms.o \ + sms_I.o \ + sms92.o +$(EXE): $(OBJS) + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -APP_LIBS = -L ${GRASPLIB} ${GRASPLIBS} - -APP_OBJ= sms1_C.o teilst_C.o dvpot_C.o\ - sms_I.o getmixblock_I.o rintiso_I.o smsmcp_I.o \ - densmcp_I.o getsmd_I.o setdbg_I.o smsnew_I.o \ - densnew_I.o polint_I.o setmcp_I.o strsum_I.o \ - gco_I.o rintdens_I.o setsum_I.o vinti_I.o \ - engout_I.o wghtd5_I.o \ -\ - densmcp.o densnew.o gco.o getsmd.o polint.o rintdens.o \ - rintiso.o setdbg.o setmcp.o setsum.o sms.o sms92.o smsmcp.o \ - smsnew.o strsum.o vinti.o getmixblock.o \ - engout.o wghtd5.o - -$(EXE): $(APP_OBJ) - $(FC) -o $(BINFILE) $(FC_LD) $(APP_OBJ) $(APP_LIBS) \ - $(APP_LIBS) ${LAPACK_LIBS} -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL92} -I $(MODLRANG90) -I $(MODLMCP90) \ - -I $(MODDIR) -o $@ - -.f.o: - $(FC) -c $(FC_FLAGS) $< -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -@rm $(EXE) + -@rm *.o *.mod diff --git a/src/lib/lib9290/BUILDCONF.sh b/src/lib/lib9290/BUILDCONF.sh new file mode 100644 index 000000000..405ee20b8 --- /dev/null +++ b/src/lib/lib9290/BUILDCONF.sh @@ -0,0 +1,81 @@ +LIB=9290 +LAPACK=true +LIBRARIES=mod +FILES=" +alcbuf.f90 alcbuf_I.f90 +arctan.f90 arctan_I.f90 +calen.f90 calen_I.f90 +cgamma.f90 cgamma_I.f90 +clrx.f90 clrx_I.f90 +convrt.f90 convrt_I.f90 +convrt2.f90 convrt2_I.f90 +convrt_double.f90 convrt_double_I.f90 +speak.f90 speak_I.f90 +cord.f90 cord_I.f90 +count.f90 count_I.f90 +cre.f90 cre_I.f90 +openfl.f90 openfl_I.f90 +setcsll.f90 setcsll_I.f90 +prsrsl.f90 prsrsl_I.f90 +prsrcn.f90 prsrcn_I.f90 +lodcsh.f90 lodcsh_I.f90 +cslh.f90 cslh_I.f90 +dcbsrw.f90 dcbsrw_I.f90 +dinit.f90 dinit_I.f90 +dmerge.f90 dmerge_I.f90 +dpbdt.f90 dpbdt_I.f90 +draw.f90 draw_I.f90 +es.f90 es_I.f90 +factt.f90 factt_I.f90 +ldigit.f90 ldigit_I.f90 +getrsl.f90 getrsl_I.f90 +getyn.f90 getyn_I.f90 +iq.f90 iq_I.f90 +ichkq1.f90 ichkq1_I.f90 +ichkq2.f90 ichkq2_I.f90 +ichop.f90 ichop_I.f90 +icopy.f90 icopy_I.f90 +iniest2.f90 iniest2_I.f90 +interp.f90 interp_I.f90 +quad.f90 quad_I.f90 +rint.f90 rint_I.f90 +intrpq.f90 intrpq_I.f90 +ispar.f90 ispar_I.f90 +items.f90 items_I.f90 +itjpo.f90 itjpo_I.f90 +itrig.f90 itrig_I.f90 +jcup.f90 jcup_I.f90 +jqs.f90 jqs_I.f90 +parsjl.f90 parsjl_I.f90 +pack.f90 pack_I.f90 +lodcsh2.f90 lodcsh2_I.f90 +lodcsl.f90 lodcsl_I.f90 +lodiso.f90 lodiso_I.f90 +orthsc.f90 orthsc_I.f90 +lodrwf.f90 lodrwf_I.f90 +lodstate.f90 lodstate_I.f90 +ltab.f90 ltab_I.f90 +nucpot.f90 nucpot_I.f90 +posfile.f90 posfile_I.f90 +radgrd.f90 radgrd_I.f90 +rinti.f90 rinti_I.f90 +setcon.f90 setcon_I.f90 +setcsh.f90 setcsh_I.f90 +setcsla.f90 setcsla_I.f90 +setiso.f90 setiso_I.f90 +setj.f90 setj_I.f90 +setmc.f90 setmc_I.f90 +setpot.f90 setpot_I.f90 +setqic.f90 setqic_I.f90 +setqna.f90 setqna_I.f90 +setrwfa.f90 setrwfa_I.f90 +skrc.f90 skrc_I.f90 +yzk.f90 yzk_I.f90 +slater.f90 slater_I.f90 +spicmv2.f90 spicmv2_I.f90 +start.f90 start_I.f90 +starttime.f90 starttime_I.f90 +stoptime.f90 stoptime_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/lib9290/CMakeLists.txt b/src/lib/lib9290/CMakeLists.txt new file mode 100644 index 000000000..c35f673b0 --- /dev/null +++ b/src/lib/lib9290/CMakeLists.txt @@ -0,0 +1,155 @@ +add_library(9290 STATIC + alcbuf.f90 + alcbuf_I.f90 + arctan.f90 + arctan_I.f90 + calen.f90 + calen_I.f90 + cgamma.f90 + cgamma_I.f90 + clrx.f90 + clrx_I.f90 + convrt.f90 + convrt_I.f90 + convrt2.f90 + convrt2_I.f90 + convrt_double.f90 + convrt_double_I.f90 + speak.f90 + speak_I.f90 + cord.f90 + cord_I.f90 + count.f90 + count_I.f90 + cre.f90 + cre_I.f90 + openfl.f90 + openfl_I.f90 + setcsll.f90 + setcsll_I.f90 + prsrsl.f90 + prsrsl_I.f90 + prsrcn.f90 + prsrcn_I.f90 + lodcsh.f90 + lodcsh_I.f90 + cslh.f90 + cslh_I.f90 + dcbsrw.f90 + dcbsrw_I.f90 + dinit.f90 + dinit_I.f90 + dmerge.f90 + dmerge_I.f90 + dpbdt.f90 + dpbdt_I.f90 + draw.f90 + draw_I.f90 + es.f90 + es_I.f90 + factt.f90 + factt_I.f90 + ldigit.f90 + ldigit_I.f90 + getrsl.f90 + getrsl_I.f90 + getyn.f90 + getyn_I.f90 + iq.f90 + iq_I.f90 + ichkq1.f90 + ichkq1_I.f90 + ichkq2.f90 + ichkq2_I.f90 + ichop.f90 + ichop_I.f90 + icopy.f90 + icopy_I.f90 + iniest2.f90 + iniest2_I.f90 + interp.f90 + interp_I.f90 + quad.f90 + quad_I.f90 + rint.f90 + rint_I.f90 + intrpq.f90 + intrpq_I.f90 + ispar.f90 + ispar_I.f90 + items.f90 + items_I.f90 + itjpo.f90 + itjpo_I.f90 + itrig.f90 + itrig_I.f90 + jcup.f90 + jcup_I.f90 + jqs.f90 + jqs_I.f90 + parsjl.f90 + parsjl_I.f90 + pack.f90 + pack_I.f90 + lodcsh2.f90 + lodcsh2_I.f90 + lodcsl.f90 + lodcsl_I.f90 + lodiso.f90 + lodiso_I.f90 + orthsc.f90 + orthsc_I.f90 + lodrwf.f90 + lodrwf_I.f90 + lodstate.f90 + lodstate_I.f90 + ltab.f90 + ltab_I.f90 + nucpot.f90 + nucpot_I.f90 + posfile.f90 + posfile_I.f90 + radgrd.f90 + radgrd_I.f90 + rinti.f90 + rinti_I.f90 + setcon.f90 + setcon_I.f90 + setcsh.f90 + setcsh_I.f90 + setcsla.f90 + setcsla_I.f90 + setiso.f90 + setiso_I.f90 + setj.f90 + setj_I.f90 + setmc.f90 + setmc_I.f90 + setpot.f90 + setpot_I.f90 + setqic.f90 + setqic_I.f90 + setqna.f90 + setqna_I.f90 + setrwfa.f90 + setrwfa_I.f90 + skrc.f90 + skrc_I.f90 + yzk.f90 + yzk_I.f90 + slater.f90 + slater_I.f90 + spicmv2.f90 + spicmv2_I.f90 + start.f90 + start_I.f90 + starttime.f90 + starttime_I.f90 + stoptime.f90 + stoptime_I.f90 +) +setup_fortran_modules(9290) +target_link_libraries_Fortran(9290 PRIVATE mod) +target_link_libraries(9290 PRIVATE ${BLAS_LIBRARIES} ${BLAS_LINKER_FLAGS}) +target_link_libraries(9290 PRIVATE ${LAPACK_LIBRARIES} ${LAPACK_LINKER_FLAGS}) +install(TARGETS 9290 DESTINATION lib/) diff --git a/src/lib/lib9290/Makefile b/src/lib/lib9290/Makefile index d67f52833..a1cc2d5ad 100644 --- a/src/lib/lib9290/Makefile +++ b/src/lib/lib9290/Makefile @@ -1,53 +1,170 @@ -.SUFFIXES: .f90 .mod +LIBA=${GRASP}/lib/lib9290.a +MODULES_INSTALL=${GRASP}/lib/9290 +FC_MODULES= -I ${GRASP}/src/lib/libmod -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/lib9290.a +OBJS= \ + alcbuf.o \ + alcbuf_I.o \ + arctan.o \ + arctan_I.o \ + calen.o \ + calen_I.o \ + cgamma.o \ + cgamma_I.o \ + clrx.o \ + clrx_I.o \ + convrt.o \ + convrt_I.o \ + convrt2.o \ + convrt2_I.o \ + convrt_double.o \ + convrt_double_I.o \ + speak.o \ + speak_I.o \ + cord.o \ + cord_I.o \ + count.o \ + count_I.o \ + cre.o \ + cre_I.o \ + openfl.o \ + openfl_I.o \ + setcsll.o \ + setcsll_I.o \ + prsrsl.o \ + prsrsl_I.o \ + prsrcn.o \ + prsrcn_I.o \ + lodcsh.o \ + lodcsh_I.o \ + cslh.o \ + cslh_I.o \ + dcbsrw.o \ + dcbsrw_I.o \ + dinit.o \ + dinit_I.o \ + dmerge.o \ + dmerge_I.o \ + dpbdt.o \ + dpbdt_I.o \ + draw.o \ + draw_I.o \ + es.o \ + es_I.o \ + factt.o \ + factt_I.o \ + ldigit.o \ + ldigit_I.o \ + getrsl.o \ + getrsl_I.o \ + getyn.o \ + getyn_I.o \ + iq.o \ + iq_I.o \ + ichkq1.o \ + ichkq1_I.o \ + ichkq2.o \ + ichkq2_I.o \ + ichop.o \ + ichop_I.o \ + icopy.o \ + icopy_I.o \ + iniest2.o \ + iniest2_I.o \ + interp.o \ + interp_I.o \ + quad.o \ + quad_I.o \ + rint.o \ + rint_I.o \ + intrpq.o \ + intrpq_I.o \ + ispar.o \ + ispar_I.o \ + items.o \ + items_I.o \ + itjpo.o \ + itjpo_I.o \ + itrig.o \ + itrig_I.o \ + jcup.o \ + jcup_I.o \ + jqs.o \ + jqs_I.o \ + parsjl.o \ + parsjl_I.o \ + pack.o \ + pack_I.o \ + lodcsh2.o \ + lodcsh2_I.o \ + lodcsl.o \ + lodcsl_I.o \ + lodiso.o \ + lodiso_I.o \ + orthsc.o \ + orthsc_I.o \ + lodrwf.o \ + lodrwf_I.o \ + lodstate.o \ + lodstate_I.o \ + ltab.o \ + ltab_I.o \ + nucpot.o \ + nucpot_I.o \ + posfile.o \ + posfile_I.o \ + radgrd.o \ + radgrd_I.o \ + rinti.o \ + rinti_I.o \ + setcon.o \ + setcon_I.o \ + setcsh.o \ + setcsh_I.o \ + setcsla.o \ + setcsla_I.o \ + setiso.o \ + setiso_I.o \ + setj.o \ + setj_I.o \ + setmc.o \ + setmc_I.o \ + setpot.o \ + setpot_I.o \ + setqic.o \ + setqic_I.o \ + setqna.o \ + setqna_I.o \ + setrwfa.o \ + setrwfa_I.o \ + skrc.o \ + skrc_I.o \ + yzk.o \ + yzk_I.o \ + slater.o \ + slater_I.o \ + spicmv2.o \ + spicmv2_I.o \ + start.o \ + start_I.o \ + starttime.o \ + starttime_I.o \ + stoptime.o \ + stoptime_I.o -LIBMOD = -lmod -LIBOBJ = $(OBJ) -MODDIR = ../libmod +PHONY: install +install: $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) -RM = /bin/rm -f +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? -MODOBJ = \ - - -OBJ = \ - alcbuf_I.o calen_I.o clrx_I.o convrt_double_I.o convrt_I.o cord_I.o \ - cre_I.o cslh_I.o dinit_I.o dmerge_I.o factt_I.o convrt2_I.o \ - getyn_I.o ichkq1_I.o ichkq2_I.o ichop_I.o icopy_I.o iq_I.o intrpq_I.o \ - ispar_I.o itjpo_I.o itrig_I.o jcup_I.o jqs_I.o \ - lodcsh_I.o lodcsh2_I.o lodcsl_I.o lodiso_I.o ltab_I.o openfl_I.o orthsc_I.o\ - quad_I.o pack_I.o posfile_I.o interp_I.o\ - parsjl_I.o prsrcn_I.o prsrsl_I.o rint_I.o speak_I.o\ - setcsll_I.o setiso_I.o setj_I.o setmc_I.o setcsh_I.o setcsla_I.o setqna_I.o \ - skrc_I.o starttime_I.o stoptime_I.o count_I.o dpbdt_I.o draw_I.o rinti_I.o \ - slater_I.o yzk_I.o dcbsrw_I.o setpot_I.o cgamma_I.o arctan_I.o start_I.o \ - lodstate_I.o getrsl_I.o items_I.o ldigit_I.o setqic_I.o radgrd_I.o \ - nucpot_I.o setrwfa_I.o es_I.o lodrwf_I.o spicmv2_I.o iniest2_I.o \ - setcon_I.o \ - \ - alcbuf.o calen.o clrx.o convrt_double.o convrt.o cord.o \ - cre.o cslh.o dinit.o dmerge.o factt.o convrt2.o \ - getyn.o ichkq1.o ichkq2.o ichop.o icopy.o iq.o intrpq.o \ - ispar.o itjpo.o itrig.o jcup.o jqs.o \ - lodcsh.o lodcsh2.o lodcsl.o lodiso.o ltab.o openfl.o orthsc.o \ - quad.o pack.o posfile.o interp.o \ - parsjl.o prsrcn.o prsrsl.o rint.o speak.o\ - setcsll.o setiso.o setj.o setmc.o setcsh.o setcsla.o setqna.o \ - skrc.o starttime.o stoptime.o count.o dpbdt.o draw.o rinti.o \ - slater.o yzk.o dcbsrw.o setpot.o cgamma.o arctan.o start.o \ - lodstate.o getrsl.o items.o ldigit.o setqic.o radgrd.o \ - nucpot.o setrwfa.o es.o lodrwf.o spicmv2.o iniest2.o \ - setcon.o - -install : $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -crvs $(LIBA) $? +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I . -o $@ + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/lib/libdvd90/BUILDCONF.sh b/src/lib/libdvd90/BUILDCONF.sh new file mode 100644 index 000000000..e2bc295f2 --- /dev/null +++ b/src/lib/libdvd90/BUILDCONF.sh @@ -0,0 +1,14 @@ +LIB=dvd90 +LIBRARIES="mod" +FILES=" +# dvdson.f90 contains the implementation for a bunch of routines, but we +# have separate interface files for them +adds_I.f90 dvdrvr_I.f90 dvdson_I.f90 initdvd_I.f90 mgs_nrm_I.f90 +multbc_I.f90 newvec_I.f90 ovflow_I.f90 tstsel_I.f90 +dvdson.f90 + +gdvd.f90 gdvd_I.f90 +iniest.f90 iniest_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/libdvd90/CMakeLists.txt b/src/lib/libdvd90/CMakeLists.txt new file mode 100644 index 000000000..1e78f83fc --- /dev/null +++ b/src/lib/libdvd90/CMakeLists.txt @@ -0,0 +1,19 @@ +add_library(dvd90 STATIC + adds_I.f90 + dvdrvr_I.f90 + dvdson_I.f90 + initdvd_I.f90 + mgs_nrm_I.f90 + multbc_I.f90 + newvec_I.f90 + ovflow_I.f90 + tstsel_I.f90 + dvdson.f90 + gdvd.f90 + gdvd_I.f90 + iniest.f90 + iniest_I.f90 +) +setup_fortran_modules(dvd90) +target_link_libraries_Fortran(dvd90 PRIVATE mod) +install(TARGETS dvd90 DESTINATION lib/) diff --git a/src/lib/libdvd90/Makefile b/src/lib/libdvd90/Makefile index 163a70f82..87fc3dc05 100644 --- a/src/lib/libdvd90/Makefile +++ b/src/lib/libdvd90/Makefile @@ -1,32 +1,36 @@ -.SUFFIXES: .f90 .mod - -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libdvd90.a - -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 -MODLMPIU90 = ../mpi90 - -RM= /bin/rm -f - - -OBJ = \ - adds_I.o gdvd_I.o mgs_nrm_I.o ovflow_I.o \ - dvdrvr_I.o iniest_I.o multbc_I.o tstsel_I.o \ - dvdson_I.o initdvd_I.o newvec_I.o \ -\ - dvdson.o gdvd.o iniest.o - - +LIBA=${GRASP}/lib/libdvd90.a +MODULES_INSTALL=${GRASP}/lib/dvd90 +FC_MODULES= -I ${GRASP}/src/lib/libmod + +OBJS= \ + adds_I.o \ + dvdrvr_I.o \ + dvdson_I.o \ + initdvd_I.o \ + mgs_nrm_I.o \ + multbc_I.o \ + newvec_I.o \ + ovflow_I.o \ + tstsel_I.o \ + dvdson.o \ + gdvd.o \ + gdvd_I.o \ + iniest.o \ + iniest_I.o + +PHONY: install install: $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -curvs $(LIBA) $(LIBOBJ) - ranlib $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) + +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - rm -f *.o *.mod core + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/lib/libdvd90/Makefile_Ser b/src/lib/libdvd90/Makefile_Ser deleted file mode 100644 index 23b075bc8..000000000 --- a/src/lib/libdvd90/Makefile_Ser +++ /dev/null @@ -1,35 +0,0 @@ -.SUFFIXES: .f90 .mod - -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libdvd90.a - -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 -VASTO = $(MODDIR)/vast_kind_param_M.o -PARDEF = $(MODDIR)/parameter_def_M.o -F90 = $(FC) -F90_FLAGS = $(FC_FLAGS) - -RM= /bin/rm -f - - -OBJ = \ - mpi_C.o adds_I.o gdvd_I.o mgs_nrm_I.o ovflow_I.o \ - dvdrvr_I.o iniest_I.o multbc_I.o tstsel_I.o \ - dvdson_I.o initdvd_I.o newvec_I.o \ -\ - dvdson.o gdvd.o iniest.o - - -install: $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -curvs $(LIBA) $(LIBOBJ) - ranlib $(LIBA) - -.f90.o: - $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I . -o $@ - -clean: - rm -f *.o *.mod core diff --git a/src/lib/libdvd90/Makefile_mpi b/src/lib/libdvd90/Makefile_mpi deleted file mode 100644 index a2104fefb..000000000 --- a/src/lib/libdvd90/Makefile_mpi +++ /dev/null @@ -1,36 +0,0 @@ -.SUFFIXES: .f90 .mod - -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libdvd90.a - -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 -MODLMPIU90 = ../mpi90 -VASTO = $(MODDIR)/vast_kind_param_M.o -PARDEF = $(MODDIR)/parameter_def_M.o -F90 = $(FC) -F90_FLAGS = $(FC_FLAGS) - -RM= /bin/rm -f - - -OBJ = \ - adds_I.o gdvd_I.o mgs_nrm_I.o ovflow_I.o \ - dvdrvr_I.o iniest_I.o multbc_I.o tstsel_I.o \ - dvdson_I.o initdvd_I.o newvec_I.o \ -\ - dvdson.o gdvd.o iniest.o - - -install: $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -curvs $(LIBA) $(LIBOBJ) - ranlib $(LIBA) - -.f90.o: - $(F90) -c $(F90_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMPIU90) -I . -o $@ - -clean: - rm -f *.o *.mod core diff --git a/src/lib/libmcp90/BUILDCONF.sh b/src/lib/libmcp90/BUILDCONF.sh new file mode 100644 index 000000000..1f0360c46 --- /dev/null +++ b/src/lib/libmcp90/BUILDCONF.sh @@ -0,0 +1,8 @@ +LIB=mcp90 +LIBRARIES="mod 9290" +FILES=" +cxk.f90 cxk_I.f90 +talk.f90 talk_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/libmcp90/CMakeLists.txt b/src/lib/libmcp90/CMakeLists.txt new file mode 100644 index 000000000..ccb40e922 --- /dev/null +++ b/src/lib/libmcp90/CMakeLists.txt @@ -0,0 +1,9 @@ +add_library(mcp90 STATIC + cxk.f90 + cxk_I.f90 + talk.f90 + talk_I.f90 +) +setup_fortran_modules(mcp90) +target_link_libraries_Fortran(mcp90 PRIVATE mod 9290) +install(TARGETS mcp90 DESTINATION lib/) diff --git a/src/lib/libmcp90/Makefile b/src/lib/libmcp90/Makefile index 949b6f034..288fb5045 100644 --- a/src/lib/libmcp90/Makefile +++ b/src/lib/libmcp90/Makefile @@ -1,30 +1,26 @@ -.SUFFIXES: .f90 .mod +LIBA=${GRASP}/lib/libmcp90.a +MODULES_INSTALL=${GRASP}/lib/mcp90 +FC_MODULES= -I ${GRASP}/src/lib/libmod -I ${GRASP}/src/lib/lib9290 -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libmcp90.a +OBJS= \ + cxk.o \ + cxk_I.o \ + talk.o \ + talk_I.o -LIBMOD = -lmod -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 +PHONY: install +install: $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) -RM = /bin/rm -f +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? -MODOBJ = \ - - -OBJ = \ - cxk_I.o talk_I.o \ - \ - cxk.o talk.o - -install : $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -crvs $(LIBA) $? +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I . -o $@ + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/lib/libmod/BUILDCONF.sh b/src/lib/libmod/BUILDCONF.sh new file mode 100644 index 000000000..06799692c --- /dev/null +++ b/src/lib/libmod/BUILDCONF.sh @@ -0,0 +1,108 @@ +LIB=mod +FILES="parameter_def_M.f90 +vast_kind_param_M.f90 +memory_man.f90 +AME_C.f90 +bcore_C.f90 +bess_C.f90 +bilst_C.f90 +biorb_C.f90 +blim_C.f90 +blk_C.f90 +blkidx_C.f90 +buffer_C.f90 +cffmat_C.f90 +ciimat_C.f90 +cimat_C.f90 +cnc_C.f90 +coeils_C.f90 +cons_C.f90 +core_C.f90 +corre_C.f90 +coun_C.f90 +couple_C.f90 +cteilsrk_C.f90 +cuto_C.f90 +damp_C.f90 +debug_C.f90 +decide_C.f90 +def_C.f90 +default_C.f90 +dumx_C.f90 +eigv_C.f90 +eigvec1_C.f90 +facts_C.f90 +fixd_C.f90 +foparm_C.f90 +fposition_C.f90 +grid_C.f90 +hblock_C.f90 +hmat_C.f90 +horb_C.f90 +hydpar_C.f90 +iccu_C.f90 +int_C.f90 +invt_C.f90 +iounit_C.f90 +jj2lsj_C.f90 +jj2lsjbio_C.f90 +jlabl_C.f90 +jqjc_C.f90 +keilst_C.f90 +kkstart_C.f90 +kkstartbreit_C.f90 +l1_C.f90 +l2_C.f90 +lagr_C.f90 +left_C.f90 +lib92p_C.f90 +lic13_C.f90 +m_C.f90 +mcp_C.f90 +mcpa_C.f90 +mcpb_C.f90 +mcpdata_C.f90 +mtjj2_C.f90 +mtjj_C.f90 +ncc_C.f90 +ncdist_C.f90 +node_C.f90 +npar_C.f90 +npot_C.f90 +offd_C.f90 +orb_C.f90 +orba_C.f90 +orbord_C.f90 +orthct_C.f90 +osc_C.f90 +ovl_C.f90 +peav_C.f90 +pos_C.f90 +pote_C.f90 +prnt_C.f90 +qedcut_C.f90 +rang_Int_C.f90 +ribojj11_C.f90 +ribojj9_C.f90 +ribojj_C.f90 +sacoef_C.f90 +sbc_C.f90 +sbdat1_C.f90 +sbdat_C.f90 +scf_C.f90 +stat_C.f90 +stor_C.f90 +syma_C.f90 +tatb_C.f90 +terms_C.f90 +titl_C.f90 +trk_C.f90 +vinlst_C.f90 +vpilst_C.f90 +wave_C.f90 +wchblk_C.f90 +wfac_C.f90 +where_C.f90 +whfrom_C.f90" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/libmod/CMakeLists.txt b/src/lib/libmod/CMakeLists.txt new file mode 100644 index 000000000..697cb8c87 --- /dev/null +++ b/src/lib/libmod/CMakeLists.txt @@ -0,0 +1,109 @@ +add_library(mod STATIC + parameter_def_M.f90 + vast_kind_param_M.f90 + memory_man.f90 + AME_C.f90 + bcore_C.f90 + bess_C.f90 + bilst_C.f90 + biorb_C.f90 + blim_C.f90 + blk_C.f90 + blkidx_C.f90 + buffer_C.f90 + cffmat_C.f90 + ciimat_C.f90 + cimat_C.f90 + cnc_C.f90 + coeils_C.f90 + cons_C.f90 + core_C.f90 + corre_C.f90 + coun_C.f90 + couple_C.f90 + cteilsrk_C.f90 + cuto_C.f90 + damp_C.f90 + debug_C.f90 + decide_C.f90 + def_C.f90 + default_C.f90 + dumx_C.f90 + eigv_C.f90 + eigvec1_C.f90 + facts_C.f90 + fixd_C.f90 + foparm_C.f90 + fposition_C.f90 + grid_C.f90 + hblock_C.f90 + hmat_C.f90 + horb_C.f90 + hydpar_C.f90 + iccu_C.f90 + int_C.f90 + invt_C.f90 + iounit_C.f90 + jj2lsj_C.f90 + jj2lsjbio_C.f90 + jlabl_C.f90 + jqjc_C.f90 + keilst_C.f90 + kkstart_C.f90 + kkstartbreit_C.f90 + l1_C.f90 + l2_C.f90 + lagr_C.f90 + left_C.f90 + lib92p_C.f90 + lic13_C.f90 + m_C.f90 + mcp_C.f90 + mcpa_C.f90 + mcpb_C.f90 + mcpdata_C.f90 + mtjj2_C.f90 + mtjj_C.f90 + ncc_C.f90 + ncdist_C.f90 + node_C.f90 + npar_C.f90 + npot_C.f90 + offd_C.f90 + orb_C.f90 + orba_C.f90 + orbord_C.f90 + orthct_C.f90 + osc_C.f90 + ovl_C.f90 + peav_C.f90 + pos_C.f90 + pote_C.f90 + prnt_C.f90 + qedcut_C.f90 + rang_Int_C.f90 + ribojj11_C.f90 + ribojj9_C.f90 + ribojj_C.f90 + sacoef_C.f90 + sbc_C.f90 + sbdat1_C.f90 + sbdat_C.f90 + scf_C.f90 + stat_C.f90 + stor_C.f90 + syma_C.f90 + tatb_C.f90 + terms_C.f90 + titl_C.f90 + trk_C.f90 + vinlst_C.f90 + vpilst_C.f90 + wave_C.f90 + wchblk_C.f90 + wfac_C.f90 + where_C.f90 + whfrom_C.f90 +) +setup_fortran_modules(mod) +install(TARGETS mod DESTINATION lib/) diff --git a/src/lib/libmod/Makefile b/src/lib/libmod/Makefile index 43ffe32e8..6cb2bef31 100644 --- a/src/lib/libmod/Makefile +++ b/src/lib/libmod/Makefile @@ -1,74 +1,126 @@ -.SUFFIXES: .f90 .mod +LIBA=${GRASP}/lib/libmod.a +MODULES_INSTALL=${GRASP}/lib/mod -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libmod.a -F90 = $(FC) -F90_FLAGS = $(FC_FLAGS) +OBJS= \ + parameter_def_M.o \ + vast_kind_param_M.o \ + memory_man.o \ + AME_C.o \ + bcore_C.o \ + bess_C.o \ + bilst_C.o \ + biorb_C.o \ + blim_C.o \ + blk_C.o \ + blkidx_C.o \ + buffer_C.o \ + cffmat_C.o \ + ciimat_C.o \ + cimat_C.o \ + cnc_C.o \ + coeils_C.o \ + cons_C.o \ + core_C.o \ + corre_C.o \ + coun_C.o \ + couple_C.o \ + cteilsrk_C.o \ + cuto_C.o \ + damp_C.o \ + debug_C.o \ + decide_C.o \ + def_C.o \ + default_C.o \ + dumx_C.o \ + eigv_C.o \ + eigvec1_C.o \ + facts_C.o \ + fixd_C.o \ + foparm_C.o \ + fposition_C.o \ + grid_C.o \ + hblock_C.o \ + hmat_C.o \ + horb_C.o \ + hydpar_C.o \ + iccu_C.o \ + int_C.o \ + invt_C.o \ + iounit_C.o \ + jj2lsj_C.o \ + jj2lsjbio_C.o \ + jlabl_C.o \ + jqjc_C.o \ + keilst_C.o \ + kkstart_C.o \ + kkstartbreit_C.o \ + l1_C.o \ + l2_C.o \ + lagr_C.o \ + left_C.o \ + lib92p_C.o \ + lic13_C.o \ + m_C.o \ + mcp_C.o \ + mcpa_C.o \ + mcpb_C.o \ + mcpdata_C.o \ + mtjj2_C.o \ + mtjj_C.o \ + ncc_C.o \ + ncdist_C.o \ + node_C.o \ + npar_C.o \ + npot_C.o \ + offd_C.o \ + orb_C.o \ + orba_C.o \ + orbord_C.o \ + orthct_C.o \ + osc_C.o \ + ovl_C.o \ + peav_C.o \ + pos_C.o \ + pote_C.o \ + prnt_C.o \ + qedcut_C.o \ + rang_Int_C.o \ + ribojj11_C.o \ + ribojj9_C.o \ + ribojj_C.o \ + sacoef_C.o \ + sbc_C.o \ + sbdat1_C.o \ + sbdat_C.o \ + scf_C.o \ + stat_C.o \ + stor_C.o \ + syma_C.o \ + tatb_C.o \ + terms_C.o \ + titl_C.o \ + trk_C.o \ + vinlst_C.o \ + vpilst_C.o \ + wave_C.o \ + wchblk_C.o \ + wfac_C.o \ + where_C.o \ + whfrom_C.o -RM = /bin/rm -f +PHONY: install +install: $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) -VASTO = vast_kind_param_M.o -PARDEF = parameter_def_M.o +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? -MODOBJ = \ - memory_man.o \ - biorb_C.o blk_C.o buffer_C.o cffmat_C.o ciimat_C.o cimat_C.o \ - cons_C.o couple_C.o cuto_C.o debug_C.o default_C.o hmat_C.o hblock_C.o iccu_C.o \ - \ - def_C.o default_C.o dumx_C.o grid_C.o iounit_C.o jj2lsj_C.o l1_C.o l2_C.o \ - \ - eigv_C.o facts_C.o foparm_C.o jqjc_C.o lib92p_C.o m_C.o mcp_C.o mtjj_C.o mtjj2_C.o \ - ncc_C.o npar_C.o orb_C.o orbord_C.o osc_C.o prnt_C.o left_C.o eigvec1_C.o \ - jj2lsjbio_C.o mcpdata_C.o offd_C.o \ - ribojj_C.o ribojj9_C.o ribojj11_C.o sbc_C.o sbdat_C.o sbdat1_C.o stat_C.o syma_C.o \ -\ - tatb_C.o terms_C.o titl_C.o trk_C.o hydpar_C.o qedcut_C.o\ -\ - rang_Int_C.o AME_C.o wave_C.o int_C.o scf_C.o pos_C.o jlabl_C.o npot_C.o pote_C.o \ - damp_C.o invt_C.o coun_C.o lic13_C.o peav_C.o lagr_C.o fixd_C.o \ - ovl_C.o orba_C.o core_C.o corre_C.o cnc_C.o node_C.o wfac_C.o orthct_C.o sbc_C.o \ - where_C.o wchblk_C.o whfrom_C.o blkidx_C.o mcpa_C.o mcpb_C.o \ -\ - decide_C.o ncdist_C.o coeils_C.o bilst_C.o keilst_C.o vinlst_C.o vpilst_C.o stor_C.o bess_C.o \ - bcore_C.o cteilsrk_C.o kkstart_C.o horb_C.o blim_C.o fposition_C.o sacoef_C.o \ - kkstartbreit_C.o # mpi_C.o delete for serial code only, delte mpi_C.i +%.o: %.f90 + $(FC) -c $(FC_FLAGS) -o $@ $< - -install : $(LIBA) -$(LIBA) : ${VASTO} ${PARDEF} $(MODOBJ) - @echo " Building install libmod.a" - ar -curs $(LIBA) $? - -${MODOBJ} : ${VASTO} ${PARDEF} - - clean: - -rm -f *.o *.mod - -.f90.o: - @echo "Compiling source file $< into $@" - $(F90) -c $(F90_FLAGS) $< - -.f90.mod: - $(F90) -c $(F90_FLAGS) $? - -SRC = \ - memory_man.f90 \ - blk_C.f90 buffer_C.f90 \ - cons_C.f90 couple_C.f90 debug_C.f90 default_C.f90 hmat_C.f90 hblock_C.f90 \ - hmat_C.f90 iccu_C.f90 \ - \ - def_C.f90 default_C.f90 dumx_C.f90 grid_C.f90 iounit_C.f90 jj2lsj_C.f90 l1_C.f90 l2_C.f90 \ - \ - eigv_C.f90 facts_C.f90 foparm_C.f90 lib92p_C.f90 m_C.f90 mcp_C.f90 mtjj_C.f90 mtjj2_C.f90 \ - mpi_C.f90 ncc_C.f90 npar_C.f90 orb_C.f90 prnt_C.f90 \ - \ - ribojj_C.f90 ribojj9_C.f90 ribojj11_C.f90 stat_C.f90 syma_C.f90 \ - itatb_C.f90 terms_C.f90 AME_C.f90 trk_C.f90 \ -\ - rang_Int_C.f90 wave_C.f90 int_C.f90 scf_C.f90 pos_C.f90 jlabl_C.f90 npot_C.f90 pote_C.f90 \ - damp_C.f90 invt_C.f90 coun_C.f90 lic13_C.f90 peav_C.f90 lagr_C.f90 fixd_C.f90 \ - ovl_C.f90 orba_C.f90 core_C.f90 corre_C.f90 cnc_C.f90 node_C.f90 wfac_C.f90 orthct_C.f90 \ - sbc_C.f90 where_C.f90 wchblk_C.f90 blkidx_C.f90 mcpa_C.f90 mcpb_C.f90 \ -\ - decide_C.f90 ncdist_C.f90 coeils_C.f90 bilst_C.f90 keilst_C.f90 vinlst_C.f90 vpilst_C.f90 stor_C.f90 bess_C.f90 \ - bcore_C.f90 cteilsrk_C.f90 kkstart_C.f90 horb_C.f90 qedcut_C.f90 +clean: + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/lib/librang90/BUILDCONF.sh b/src/lib/librang90/BUILDCONF.sh new file mode 100644 index 000000000..5af0c4c8f --- /dev/null +++ b/src/lib/librang90/BUILDCONF.sh @@ -0,0 +1,95 @@ +LIB=rang90 +LIBRARIES="mod 9290 mcp90" +FILES=" +Gracah1.f90 Gracah1_I.f90 +jthn.f90 jthn_I.f90 +rumtjj.f90 rumtjj_I.f90 +ittk.f90 ittk_I.f90 +c0t5s.f90 c0t5s_I.f90 +Rmeajj11.f90 Rmeajj11_I.f90 +Rmeajj9.f90 Rmeajj9_I.f90 +Rmew1jj.f90 Rmew1jj_I.f90 +Rmew3jj.f90 Rmew3jj_I.f90 +Rmew5jj.f90 Rmew5jj_I.f90 +Rmew7bjj.f90 Rmew7bjj_I.f90 +Rmew7jj.f90 Rmew7jj_I.f90 +Rmeajj.f90 Rmeajj_I.f90 +Rwjj.f90 Rwjj_I.f90 +a1jj.f90 a1jj_I.f90 +mes.f90 mes_I.f90 +itjj.f90 itjj_I.f90 +itjj2.f90 itjj2_I.f90 +itjj3.f90 itjj3_I.f90 +ixjtik.f90 ixjtik_I.f90 +itrexg.f90 itrexg_I.f90 +izas1.f90 izas1_I.f90 +jfaze.f90 jfaze_I.f90 +sixj1.f90 sixj1_I.f90 +sixj2.f90 sixj2_I.f90 +sixj3.f90 sixj3_I.f90 +sixj35.f90 sixj35_I.f90 +dracah.f90 dracah_I.f90 +sixj4.f90 sixj4_I.f90 +sixj5.f90 sixj5_I.f90 +sixj.f90 sixj_I.f90 +awp1.f90 awp1_I.f90 +w1jjg.f90 w1jjg_I.f90 +wap1jjg.f90 wap1jjg_I.f90 +c1e0sm.f90 c1e0sm_I.f90 +c1e1sm.f90 c1e1sm_I.f90 +cle0sm.f90 cle0sm_I.f90 +wj1.f90 wj1_I.f90 +ww1.f90 ww1_I.f90 +wap1.f90 wap1_I.f90 +awp1jjg.f90 awp1jjg_I.f90 +coulom.f90 coulom_I.f90 +nine0.f90 nine0_I.f90 +nine.f90 nine_I.f90 +diaga1.f90 diaga1_I.f90 +diaga2.f90 diaga2_I.f90 +diaga3.f90 diaga3_I.f90 +diaga4.f90 diaga4_I.f90 +diaga5.f90 diaga5_I.f90 +eile.f90 eile_I.f90 +reco2.f90 reco2_I.f90 +reco3.f90 reco3_I.f90 +reco4.f90 reco4_I.f90 +reco.f90 reco_I.f90 +rec3.f90 rec3_I.f90 +nmtejj.f90 nmtejj_I.f90 +perko1.f90 perko1_I.f90 +perko2.f90 perko2_I.f90 +snrc.f90 snrc_I.f90 +gg1112.f90 gg1112_I.f90 +gg1122.f90 gg1122_I.f90 +gg12.f90 gg12_I.f90 +gg1222.f90 gg1222_I.f90 +gg1233.f90 gg1233_I.f90 +gg1234.f90 gg1234_I.f90 +el1.f90 el1_I.f90 +el2.f90 el2_I.f90 +el31.f90 el31_I.f90 +el32.f90 el32_I.f90 +el33.f90 el33_I.f90 +el3.f90 el3_I.f90 +el41.f90 el41_I.f90 +el4.f90 el4_I.f90 +el51.f90 el51_I.f90 +el52.f90 el52_I.f90 +el53.f90 el53_I.f90 +el5.f90 el5_I.f90 +recop1.f90 recop1_I.f90 +recop2.f90 recop2_I.f90 +recop00.f90 recop00_I.f90 +oneparticlejj1.f90 oneparticlejj1_I.f90 +oneparticlejj2.f90 oneparticlejj2_I.f90 +oneparticlejj.f90 oneparticlejj_I.f90 +recoonescalar.f90 recoonescalar_I.f90 +onescalar1.f90 onescalar1_I.f90 +onescalar2.f90 onescalar2_I.f90 +onescalar.f90 onescalar_I.f90 +rkco_gg.f90 rkco_gg_I.f90 +suwjj.f90 suwjj_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/librang90/CMakeLists.txt b/src/lib/librang90/CMakeLists.txt new file mode 100644 index 000000000..21cc26c68 --- /dev/null +++ b/src/lib/librang90/CMakeLists.txt @@ -0,0 +1,183 @@ +add_library(rang90 STATIC + Gracah1.f90 + Gracah1_I.f90 + jthn.f90 + jthn_I.f90 + rumtjj.f90 + rumtjj_I.f90 + ittk.f90 + ittk_I.f90 + c0t5s.f90 + c0t5s_I.f90 + Rmeajj11.f90 + Rmeajj11_I.f90 + Rmeajj9.f90 + Rmeajj9_I.f90 + Rmew1jj.f90 + Rmew1jj_I.f90 + Rmew3jj.f90 + Rmew3jj_I.f90 + Rmew5jj.f90 + Rmew5jj_I.f90 + Rmew7bjj.f90 + Rmew7bjj_I.f90 + Rmew7jj.f90 + Rmew7jj_I.f90 + Rmeajj.f90 + Rmeajj_I.f90 + Rwjj.f90 + Rwjj_I.f90 + a1jj.f90 + a1jj_I.f90 + mes.f90 + mes_I.f90 + itjj.f90 + itjj_I.f90 + itjj2.f90 + itjj2_I.f90 + itjj3.f90 + itjj3_I.f90 + ixjtik.f90 + ixjtik_I.f90 + itrexg.f90 + itrexg_I.f90 + izas1.f90 + izas1_I.f90 + jfaze.f90 + jfaze_I.f90 + sixj1.f90 + sixj1_I.f90 + sixj2.f90 + sixj2_I.f90 + sixj3.f90 + sixj3_I.f90 + sixj35.f90 + sixj35_I.f90 + dracah.f90 + dracah_I.f90 + sixj4.f90 + sixj4_I.f90 + sixj5.f90 + sixj5_I.f90 + sixj.f90 + sixj_I.f90 + awp1.f90 + awp1_I.f90 + w1jjg.f90 + w1jjg_I.f90 + wap1jjg.f90 + wap1jjg_I.f90 + c1e0sm.f90 + c1e0sm_I.f90 + c1e1sm.f90 + c1e1sm_I.f90 + cle0sm.f90 + cle0sm_I.f90 + wj1.f90 + wj1_I.f90 + ww1.f90 + ww1_I.f90 + wap1.f90 + wap1_I.f90 + awp1jjg.f90 + awp1jjg_I.f90 + coulom.f90 + coulom_I.f90 + nine0.f90 + nine0_I.f90 + nine.f90 + nine_I.f90 + diaga1.f90 + diaga1_I.f90 + diaga2.f90 + diaga2_I.f90 + diaga3.f90 + diaga3_I.f90 + diaga4.f90 + diaga4_I.f90 + diaga5.f90 + diaga5_I.f90 + eile.f90 + eile_I.f90 + reco2.f90 + reco2_I.f90 + reco3.f90 + reco3_I.f90 + reco4.f90 + reco4_I.f90 + reco.f90 + reco_I.f90 + rec3.f90 + rec3_I.f90 + nmtejj.f90 + nmtejj_I.f90 + perko1.f90 + perko1_I.f90 + perko2.f90 + perko2_I.f90 + snrc.f90 + snrc_I.f90 + gg1112.f90 + gg1112_I.f90 + gg1122.f90 + gg1122_I.f90 + gg12.f90 + gg12_I.f90 + gg1222.f90 + gg1222_I.f90 + gg1233.f90 + gg1233_I.f90 + gg1234.f90 + gg1234_I.f90 + el1.f90 + el1_I.f90 + el2.f90 + el2_I.f90 + el31.f90 + el31_I.f90 + el32.f90 + el32_I.f90 + el33.f90 + el33_I.f90 + el3.f90 + el3_I.f90 + el41.f90 + el41_I.f90 + el4.f90 + el4_I.f90 + el51.f90 + el51_I.f90 + el52.f90 + el52_I.f90 + el53.f90 + el53_I.f90 + el5.f90 + el5_I.f90 + recop1.f90 + recop1_I.f90 + recop2.f90 + recop2_I.f90 + recop00.f90 + recop00_I.f90 + oneparticlejj1.f90 + oneparticlejj1_I.f90 + oneparticlejj2.f90 + oneparticlejj2_I.f90 + oneparticlejj.f90 + oneparticlejj_I.f90 + recoonescalar.f90 + recoonescalar_I.f90 + onescalar1.f90 + onescalar1_I.f90 + onescalar2.f90 + onescalar2_I.f90 + onescalar.f90 + onescalar_I.f90 + rkco_gg.f90 + rkco_gg_I.f90 + suwjj.f90 + suwjj_I.f90 +) +setup_fortran_modules(rang90) +target_link_libraries_Fortran(rang90 PRIVATE mod 9290 mcp90) +install(TARGETS rang90 DESTINATION lib/) diff --git a/src/lib/librang90/Makefile b/src/lib/librang90/Makefile index b22137ae7..a9c3d10ec 100644 --- a/src/lib/librang90/Makefile +++ b/src/lib/librang90/Makefile @@ -1,61 +1,200 @@ -.SUFFIXES: .f90 .mod +LIBA=${GRASP}/lib/librang90.a +MODULES_INSTALL=${GRASP}/lib/rang90 +FC_MODULES= -I ${GRASP}/src/lib/libmod -I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmcp90 -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/librang90.a +OBJS= \ + Gracah1.o \ + Gracah1_I.o \ + jthn.o \ + jthn_I.o \ + rumtjj.o \ + rumtjj_I.o \ + ittk.o \ + ittk_I.o \ + c0t5s.o \ + c0t5s_I.o \ + Rmeajj11.o \ + Rmeajj11_I.o \ + Rmeajj9.o \ + Rmeajj9_I.o \ + Rmew1jj.o \ + Rmew1jj_I.o \ + Rmew3jj.o \ + Rmew3jj_I.o \ + Rmew5jj.o \ + Rmew5jj_I.o \ + Rmew7bjj.o \ + Rmew7bjj_I.o \ + Rmew7jj.o \ + Rmew7jj_I.o \ + Rmeajj.o \ + Rmeajj_I.o \ + Rwjj.o \ + Rwjj_I.o \ + a1jj.o \ + a1jj_I.o \ + mes.o \ + mes_I.o \ + itjj.o \ + itjj_I.o \ + itjj2.o \ + itjj2_I.o \ + itjj3.o \ + itjj3_I.o \ + ixjtik.o \ + ixjtik_I.o \ + itrexg.o \ + itrexg_I.o \ + izas1.o \ + izas1_I.o \ + jfaze.o \ + jfaze_I.o \ + sixj1.o \ + sixj1_I.o \ + sixj2.o \ + sixj2_I.o \ + sixj3.o \ + sixj3_I.o \ + sixj35.o \ + sixj35_I.o \ + dracah.o \ + dracah_I.o \ + sixj4.o \ + sixj4_I.o \ + sixj5.o \ + sixj5_I.o \ + sixj.o \ + sixj_I.o \ + awp1.o \ + awp1_I.o \ + w1jjg.o \ + w1jjg_I.o \ + wap1jjg.o \ + wap1jjg_I.o \ + c1e0sm.o \ + c1e0sm_I.o \ + c1e1sm.o \ + c1e1sm_I.o \ + cle0sm.o \ + cle0sm_I.o \ + wj1.o \ + wj1_I.o \ + ww1.o \ + ww1_I.o \ + wap1.o \ + wap1_I.o \ + awp1jjg.o \ + awp1jjg_I.o \ + coulom.o \ + coulom_I.o \ + nine0.o \ + nine0_I.o \ + nine.o \ + nine_I.o \ + diaga1.o \ + diaga1_I.o \ + diaga2.o \ + diaga2_I.o \ + diaga3.o \ + diaga3_I.o \ + diaga4.o \ + diaga4_I.o \ + diaga5.o \ + diaga5_I.o \ + eile.o \ + eile_I.o \ + reco2.o \ + reco2_I.o \ + reco3.o \ + reco3_I.o \ + reco4.o \ + reco4_I.o \ + reco.o \ + reco_I.o \ + rec3.o \ + rec3_I.o \ + nmtejj.o \ + nmtejj_I.o \ + perko1.o \ + perko1_I.o \ + perko2.o \ + perko2_I.o \ + snrc.o \ + snrc_I.o \ + gg1112.o \ + gg1112_I.o \ + gg1122.o \ + gg1122_I.o \ + gg12.o \ + gg12_I.o \ + gg1222.o \ + gg1222_I.o \ + gg1233.o \ + gg1233_I.o \ + gg1234.o \ + gg1234_I.o \ + el1.o \ + el1_I.o \ + el2.o \ + el2_I.o \ + el31.o \ + el31_I.o \ + el32.o \ + el32_I.o \ + el33.o \ + el33_I.o \ + el3.o \ + el3_I.o \ + el41.o \ + el41_I.o \ + el4.o \ + el4_I.o \ + el51.o \ + el51_I.o \ + el52.o \ + el52_I.o \ + el53.o \ + el53_I.o \ + el5.o \ + el5_I.o \ + recop1.o \ + recop1_I.o \ + recop2.o \ + recop2_I.o \ + recop00.o \ + recop00_I.o \ + oneparticlejj1.o \ + oneparticlejj1_I.o \ + oneparticlejj2.o \ + oneparticlejj2_I.o \ + oneparticlejj.o \ + oneparticlejj_I.o \ + recoonescalar.o \ + recoonescalar_I.o \ + onescalar1.o \ + onescalar1_I.o \ + onescalar2.o \ + onescalar2_I.o \ + onescalar.o \ + onescalar_I.o \ + rkco_gg.o \ + rkco_gg_I.o \ + suwjj.o \ + suwjj_I.o -LIBMOD = -lmod -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 -MODLMCP90 = ../libmcp90 +PHONY: install +install: $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) -RM= /bin/rm -f +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? -MODOBJ = \ - - -OBJ = \ - a1jj_I.o awp1_I.o w1jjg_I.o awp1jjg_I.o wap1_I.o wap1jjg_I.o wj1_I.o \ - ww1_I.o suwjj_I.o nmtejj_I.o jfaze_I.o perko1_I.o perko2_I.o \ - itrexg_I.o itjj_I.o itjj2_I.o itjj3_I.o izas1_I.o mes_I.o eile_I.o \ - Rmeajj_I.o Rmeajj9_I.o Rmeajj11_I.o Rwjj_I.o \ - Rmew1jj_I.o Rmew3jj_I.o Rmew5jj_I.o Rmew7jj_I.o Rmew7bjj_I.o \ - c0t5s_I.o c1e0sm_I.o cle0sm_I.o c1e1sm_I.o jthn_I.o rumtjj_I.o Gracah1_I.o \ - dracah_I.o ittk_I.o nine0_I.o sixj1_I.o sixj35_I.o sixj4_I.o sixj_I.o \ - ixjtik_I.o nine_I.o sixj2_I.o sixj3_I.o sixj5_I.o snrc_I.o\ - onescalar_I.o onescalar1_I.o onescalar2_I.o \ - oneparticlejj1_I.o oneparticlejj2_I.o oneparticlejj_I.o \ - el1_I.o el2_I.o el3_I.o el31_I.o el32_I.o el33_I.o el4_I.o el41_I.o \ - el5_I.o el51_I.o el52_I.o el53_I.o rkco_gg_I.o \ - coulom_I.o diaga1_I.o diaga2_I.o diaga3_I.o diaga4_I.o diaga5_I.o \ - reco_I.o recop00_I.o recop1_I.o recop2_I.o rec3_I.o reco3_I.o \ - reco2_I.o reco4_I.o recoonescalar_I.o \ - gg12_I.o gg1112_I.o gg1122_I.o gg1222_I.o gg1233_I.o gg1234_I.o \ - \ - a1jj.o awp1.o w1jjg.o awp1jjg.o wap1.o wap1jjg.o wj1.o \ - ww1.o suwjj.o nmtejj.o jfaze.o perko1.o perko2.o \ - itrexg.o itjj.o itjj2.o itjj3.o izas1.o mes.o eile.o \ - Rmeajj.o Rmeajj9.o Rmeajj11.o Rwjj.o \ - Rmew1jj.o Rmew3jj.o Rmew5jj.o Rmew7jj.o Rmew7bjj.o \ - c0t5s.o c1e0sm.o cle0sm.o c1e1sm.o jthn.o rumtjj.o Gracah1.o \ - dracah.o ittk.o nine0.o sixj1.o sixj35.o sixj4.o sixj.o \ - ixjtik.o nine.o sixj2.o sixj3.o sixj5.o snrc.o \ - onescalar.o onescalar1.o onescalar2.o \ - oneparticlejj1.o oneparticlejj2.o oneparticlejj.o \ - el1.o el2.o el3.o el31.o el32.o el33.o el4.o el41.o \ - el5.o el51.o el52.o el53.o rkco_gg.o \ - coulom.o diaga1.o diaga2.o diaga3.o diaga4.o diaga5.o \ - reco.o recop00.o recop1.o recop2.o rec3.o reco3.o \ - reco2.o reco4.o recoonescalar.o \ - gg12.o gg1112.o gg1122.o gg1222.o gg1233.o gg1234.o - -install : $(LIBA) -$(LIBA) : $(LIBOBJ) - @echo " Building " $(LIBA) - ar -crvs $(LIBA) $? - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I $(MODL92) -I $(MODLMCP90) -I $(MODDIR) -I . -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o *.mod core + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/lib/mpi90/BUILDCONF.sh b/src/lib/mpi90/BUILDCONF.sh new file mode 100644 index 000000000..3aec0d0e9 --- /dev/null +++ b/src/lib/mpi90/BUILDCONF.sh @@ -0,0 +1,20 @@ +LIB=mpiu90 +LIBRARIES="mod 9290" +ISMPI=true +FILES=" +mpi_C.f90 mpiu.f90 + +cpath.f90 cpath_I.f90 +cslhmpi.f90 cslhmpi_I.f90 +iniestmpi.f90 iniestmpi_I.f90 +lodcslmpi.f90 lodcslmpi_I.f90 +lodrwfmpi.f90 lodrwfmpi_I.f90 +setisompi.f90 setisompi_I.f90 +setrwfmpi.f90 setrwfmpi_I.f90 +spicmvmpi.f90 spicmvmpi_I.f90 +sys_chdir.f90 sys_chdir_I.f90 +sys_getwd.f90 sys_getwd_I.f90 +sys_mkdir.f90 sys_mkdir_I.f90 +" +generate-makefile > ${MAKEFILE} +generate-cmakelists > ${CMAKELISTSTXT} diff --git a/src/lib/mpi90/CMakeLists.txt b/src/lib/mpi90/CMakeLists.txt new file mode 100644 index 000000000..9996ce748 --- /dev/null +++ b/src/lib/mpi90/CMakeLists.txt @@ -0,0 +1,35 @@ +add_library(mpiu90 STATIC + mpi_C.f90 + mpiu.f90 + cpath.f90 + cpath_I.f90 + cslhmpi.f90 + cslhmpi_I.f90 + iniestmpi.f90 + iniestmpi_I.f90 + lodcslmpi.f90 + lodcslmpi_I.f90 + lodrwfmpi.f90 + lodrwfmpi_I.f90 + setisompi.f90 + setisompi_I.f90 + setrwfmpi.f90 + setrwfmpi_I.f90 + spicmvmpi.f90 + spicmvmpi_I.f90 + sys_chdir.f90 + sys_chdir_I.f90 + sys_getwd.f90 + sys_getwd_I.f90 + sys_mkdir.f90 + sys_mkdir_I.f90 +) +setup_fortran_modules(mpiu90) +target_link_libraries_Fortran(mpiu90 PRIVATE mod 9290) +target_include_directories(mpiu90 PRIVATE ${MPI_Fortran_INCLUDE_PATH}) +target_link_libraries(mpiu90 PRIVATE ${MPI_Fortran_LIBRARIES}) +set_target_properties(mpiu90 PROPERTIES + COMPILE_FLAGS "${MPI_Fortran_COMPILE_FLAGS}" + LINK_FLAGS "${MPI_Fortran_LINK_FLAGS}" +) +install(TARGETS mpiu90 DESTINATION lib/) diff --git a/src/lib/mpi90/Makefile b/src/lib/mpi90/Makefile index ae62cf6f1..e2019ab29 100644 --- a/src/lib/mpi90/Makefile +++ b/src/lib/mpi90/Makefile @@ -1,36 +1,46 @@ -.SUFFIXES: .f90 .mod - -LIBDIR = $(GRASP)/lib -LIBA = $(LIBDIR)/libmpiu90.a - -LIBOBJ = $(OBJ) -MODDIR = ../libmod -MODL92 = ../lib9290 -PARDEF = $(MODDIR)/parameter_def_M.o - -RM = /bin/rm -f - -MODOBJ = \ - - -OBJ = mpi_C.o \ - cpath_I.o cslhmpi_I.o iniestmpi_I.o lodcslmpi_I.o \ - lodrwfmpi_I.o setisompi_I.o setrwfmpi_I.o \ - spicmvmpi_I.o sys_chdir_I.o sys_getwd_I.o\ - sys_mkdir_I.o \ - \ - cpath.o cslhmpi.o iniestmpi.o lodcslmpi.o \ - lodrwfmpi.o mpiu.o setisompi.o setrwfmpi.o \ - spicmvmpi.o sys_chdir.o sys_getwd.o \ - sys_mkdir.o - -install : $(LIBA) -$(LIBA) : $(LIBOBJ) ${PARDEF} $(MODOBJ) - @echo " Building " $(LIBA) - ar -crvs $(LIBA) $? - -clean : - -rm -f *.o *.mod core - -.f90.o: - $(FC_MPI) -c $(FC_MPIFLAGS) $< -I $(MODDIR) -I $(MODL92) -I . -o $@ +LIBA=${GRASP}/lib/libmpiu90.a +MODULES_INSTALL=${GRASP}/lib/mpiu90 +FC_MODULES= -I ${GRASP}/src/lib/libmod -I ${GRASP}/src/lib/lib9290 + +OBJS= \ + mpi_C.o \ + mpiu.o \ + cpath.o \ + cpath_I.o \ + cslhmpi.o \ + cslhmpi_I.o \ + iniestmpi.o \ + iniestmpi_I.o \ + lodcslmpi.o \ + lodcslmpi_I.o \ + lodrwfmpi.o \ + lodrwfmpi_I.o \ + setisompi.o \ + setisompi_I.o \ + setrwfmpi.o \ + setrwfmpi_I.o \ + spicmvmpi.o \ + spicmvmpi_I.o \ + sys_chdir.o \ + sys_chdir_I.o \ + sys_getwd.o \ + sys_getwd_I.o \ + sys_mkdir.o \ + sys_mkdir_I.o + +PHONY: install +install: $(LIBA) + mkdir -p $(MODULES_INSTALL) + cp -v *.mod $(MODULES_INSTALL) + +$(LIBA): $(OBJS) + @echo "Installing $@" + ar -curs $@ $? + +%.o: %.f90 + $(FC_MPI) -c $(FC_MPIFLAGS) $(FC_MODULES) -o $@ $< + +clean: + -@rm $(LIBA) + -@rm *.o *.mod + -@rm -R $(MODULES_INSTALL) diff --git a/src/tool/BUILDCONF.sh b/src/tool/BUILDCONF.sh new file mode 100644 index 000000000..b7441f2f0 --- /dev/null +++ b/src/tool/BUILDCONF.sh @@ -0,0 +1,76 @@ +SCRIPTS="lscomp.pl rsave" +PROGRAMS=" +rasfsplit +rcsfblock +rcsfmr +rcsfsplit +rhfs_lsj +rlevelseV +rlevels +rmixaccumulate +rmixextract +rseqenergy +rseqhfs +rseqtrans +rtabhfs +rtablevels +rtabtrans1 +rtabtrans2 +rtabtransE1 +rwfnmchfmcdf +rwfnplot +rwfnrelabel +rwfnrotate +wfnplot +" +# rcsfratip was not being compiled in the original ${MAKEFILE} for some reason. + +# Generate ${MAKEFILE} +BINARIES_FLAT="$(for p in $SCRIPTS $PROGRAMS; do echo -n " \${GRASP}/bin/$p"; done)" +cat <<-EOF | sed 's/ /\t/' > ${MAKEFILE} + LIBS=-L \${GRASP}/lib/ -l9290 -lmod + FC_MODULES=-I \${GRASP}/src/lib/lib9290 -I \${GRASP}/src/lib/libmod + + all: ${BINARIES_FLAT} + +EOF +for script in ${SCRIPTS}; do + cat <<-EOF | sed 's/ /\t/' >> ${MAKEFILE} + \${GRASP}/bin/${script}: ${script} + cp \$^ \$@ + chmod u+x \$@ + + EOF +done +for program in ${PROGRAMS}; do + cat <<-EOF | sed 's/ /\t/' >> ${MAKEFILE} + \${GRASP}/bin/${program}: ${program}.o + \$(FC) -o \$@ \$? \$(FC_LD) \$(LIBS) \$(LAPACK_LIBS) + + EOF +done +cat <<-EOF | sed 's/ /\t/' >> ${MAKEFILE} + %.o: %.f90 + \$(FC) -c \$(FC_FLAGS) \$(FC_MODULES) -o \$@ \$< + + clean: + -rm -f ${BINARIES_FLAT} + -rm -f *.o *.mod +EOF + +# Generate CMakeLists +echo -n > ${CMAKELISTSTXT} +for script in ${SCRIPTS}; do + cat <<-EOF | sed 's/ /\t/' >> ${CMAKELISTSTXT} + install(PROGRAMS ${script} DESTINATION bin/) + EOF +done +echo >> ${CMAKELISTSTXT} +for program in ${PROGRAMS}; do + cat <<-EOF | sed 's/ /\t/' >> ${CMAKELISTSTXT} + add_executable(${program} ${program}.f90) + target_link_libraries_Fortran(${program} PRIVATE mod 9290) + install(TARGETS ${program} DESTINATION bin/) + + EOF +done diff --git a/src/tool/CMakeLists.txt b/src/tool/CMakeLists.txt new file mode 100644 index 000000000..0d61bc166 --- /dev/null +++ b/src/tool/CMakeLists.txt @@ -0,0 +1,91 @@ +install(PROGRAMS lscomp.pl DESTINATION bin/) +install(PROGRAMS rsave DESTINATION bin/) + +add_executable(rasfsplit rasfsplit.f90) +target_link_libraries_Fortran(rasfsplit PRIVATE mod 9290) +install(TARGETS rasfsplit DESTINATION bin/) + +add_executable(rcsfblock rcsfblock.f90) +target_link_libraries_Fortran(rcsfblock PRIVATE mod 9290) +install(TARGETS rcsfblock DESTINATION bin/) + +add_executable(rcsfmr rcsfmr.f90) +target_link_libraries_Fortran(rcsfmr PRIVATE mod 9290) +install(TARGETS rcsfmr DESTINATION bin/) + +add_executable(rcsfsplit rcsfsplit.f90) +target_link_libraries_Fortran(rcsfsplit PRIVATE mod 9290) +install(TARGETS rcsfsplit DESTINATION bin/) + +add_executable(rhfs_lsj rhfs_lsj.f90) +target_link_libraries_Fortran(rhfs_lsj PRIVATE mod 9290) +install(TARGETS rhfs_lsj DESTINATION bin/) + +add_executable(rlevelseV rlevelseV.f90) +target_link_libraries_Fortran(rlevelseV PRIVATE mod 9290) +install(TARGETS rlevelseV DESTINATION bin/) + +add_executable(rlevels rlevels.f90) +target_link_libraries_Fortran(rlevels PRIVATE mod 9290) +install(TARGETS rlevels DESTINATION bin/) + +add_executable(rmixaccumulate rmixaccumulate.f90) +target_link_libraries_Fortran(rmixaccumulate PRIVATE mod 9290) +install(TARGETS rmixaccumulate DESTINATION bin/) + +add_executable(rmixextract rmixextract.f90) +target_link_libraries_Fortran(rmixextract PRIVATE mod 9290) +install(TARGETS rmixextract DESTINATION bin/) + +add_executable(rseqenergy rseqenergy.f90) +target_link_libraries_Fortran(rseqenergy PRIVATE mod 9290) +install(TARGETS rseqenergy DESTINATION bin/) + +add_executable(rseqhfs rseqhfs.f90) +target_link_libraries_Fortran(rseqhfs PRIVATE mod 9290) +install(TARGETS rseqhfs DESTINATION bin/) + +add_executable(rseqtrans rseqtrans.f90) +target_link_libraries_Fortran(rseqtrans PRIVATE mod 9290) +install(TARGETS rseqtrans DESTINATION bin/) + +add_executable(rtabhfs rtabhfs.f90) +target_link_libraries_Fortran(rtabhfs PRIVATE mod 9290) +install(TARGETS rtabhfs DESTINATION bin/) + +add_executable(rtablevels rtablevels.f90) +target_link_libraries_Fortran(rtablevels PRIVATE mod 9290) +install(TARGETS rtablevels DESTINATION bin/) + +add_executable(rtabtrans1 rtabtrans1.f90) +target_link_libraries_Fortran(rtabtrans1 PRIVATE mod 9290) +install(TARGETS rtabtrans1 DESTINATION bin/) + +add_executable(rtabtrans2 rtabtrans2.f90) +target_link_libraries_Fortran(rtabtrans2 PRIVATE mod 9290) +install(TARGETS rtabtrans2 DESTINATION bin/) + +add_executable(rtabtransE1 rtabtransE1.f90) +target_link_libraries_Fortran(rtabtransE1 PRIVATE mod 9290) +install(TARGETS rtabtransE1 DESTINATION bin/) + +add_executable(rwfnmchfmcdf rwfnmchfmcdf.f90) +target_link_libraries_Fortran(rwfnmchfmcdf PRIVATE mod 9290) +install(TARGETS rwfnmchfmcdf DESTINATION bin/) + +add_executable(rwfnplot rwfnplot.f90) +target_link_libraries_Fortran(rwfnplot PRIVATE mod 9290) +install(TARGETS rwfnplot DESTINATION bin/) + +add_executable(rwfnrelabel rwfnrelabel.f90) +target_link_libraries_Fortran(rwfnrelabel PRIVATE mod 9290) +install(TARGETS rwfnrelabel DESTINATION bin/) + +add_executable(rwfnrotate rwfnrotate.f90) +target_link_libraries_Fortran(rwfnrotate PRIVATE mod 9290) +install(TARGETS rwfnrotate DESTINATION bin/) + +add_executable(wfnplot wfnplot.f90) +target_link_libraries_Fortran(wfnplot PRIVATE mod 9290) +install(TARGETS wfnplot DESTINATION bin/) + diff --git a/src/tool/Makefile b/src/tool/Makefile index f673851fa..57a2cb08a 100644 --- a/src/tool/Makefile +++ b/src/tool/Makefile @@ -1,129 +1,85 @@ -.SUFFIXES: .f90 .mod +LIBS=-L ${GRASP}/lib/ -l9290 -lmod +FC_MODULES=-I ${GRASP}/src/lib/lib9290 -I ${GRASP}/src/lib/libmod -BIN = ${GRASP}/bin -GRASPLIB = ${GRASP}/lib -SRCLIBDIR = ../lib -MODDIR = ${SRCLIBDIR}/libmod -MODL9290 = ${SRCLIBDIR}/lib9290 -GRASPLIBS = -l9290 -lmod +all: ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rsave ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot -APP_LIBS = -L${GRASPLIB} ${GRASPLIBS} ${LAPACK_LIBS} +${GRASP}/bin/lscomp.pl: lscomp.pl + cp $^ $@ + chmod u+x $@ -UTIL = rcsfsplit rmixaccumulate rseqenergy \ - rseqhfs rseqtrans rtablevels rtabtransE1 \ +${GRASP}/bin/rsave: rsave + cp $^ $@ + chmod u+x $@ -install: EXE - cp rsave $(GRASP)/bin - cp lscomp.pl $(GRASP)/bin +${GRASP}/bin/rasfsplit: rasfsplit.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -EXE : $(BIN)/rcsfsplit \ - $(BIN)/rmixaccumulate\ - $(BIN)/rseqenergy\ - $(BIN)/rseqhfs\ - $(BIN)/rseqtrans\ - $(BIN)/rtablevels\ - $(BIN)/rtabtransE1\ - $(BIN)/rcsfblock \ - $(BIN)/rwfnmchfmcdf \ - $(BIN)/rlevels \ - $(BIN)/rtabtrans1 \ - $(BIN)/rwfnplot \ - $(BIN)/rtabtrans2\ - $(BIN)/rlevelseV\ - $(BIN)/rtabhfs\ - $(BIN)/wfnplot\ - $(BIN)/rmixextract \ - $(BIN)/rasfsplit\ - $(BIN)/rwfnrotate \ - $(BIN)/rwfnrelabel \ - $(BIN)/rhfs_lsj \ - $(BIN)/rcsfmr \ +${GRASP}/bin/rcsfblock: rcsfblock.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) +${GRASP}/bin/rcsfmr: rcsfmr.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -OBJ : rasfsplit.o rcsfsplit.o rmixaccumulate.o rseqenergy.o \ - rseqhfs.o rseqtrans.o rtablevels.o rtabtransE1.o \ - rmixextract.o rcsfblock.o rwfnmchfmcdf.o \ - rlevels.o rtabtrans1.o format_mix.o rlevelsj.o \ - rwfnrotate.o \ - rwfnplot.o rtabtrans2.o rlevelseV.o rtabhfs.o wfnplot.o rwfnrelabel.o \ - rhfs_lsj.o rcsfmr.o\ +${GRASP}/bin/rcsfsplit: rcsfsplit.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rasfsplit: rasfsplit.o - $(FC) -o $(BIN)/rasfsplit rasfsplit.f90 +${GRASP}/bin/rhfs_lsj: rhfs_lsj.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rcsfsplit: rcsfsplit.o - $(FC) -o $(BIN)/rcsfsplit rcsfsplit.o +${GRASP}/bin/rlevelseV: rlevelseV.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rmixaccumulate: rmixaccumulate.o - $(FC) -o $(BIN)/rmixaccumulate rmixaccumulate.o +${GRASP}/bin/rlevels: rlevels.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rseqenergy: rseqenergy.o - $(FC) -o $(BIN)/rseqenergy rseqenergy.o +${GRASP}/bin/rmixaccumulate: rmixaccumulate.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rseqtrans: rseqtrans.o - $(FC) -o $(BIN)/rseqtrans rseqtrans.o +${GRASP}/bin/rmixextract: rmixextract.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rseqhfs: rseqhfs.o - $(FC) -o $(BIN)/rseqhfs rseqhfs.o +${GRASP}/bin/rseqenergy: rseqenergy.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rtablevels: rtablevels.o - $(FC) -o $(BIN)/rtablevels rtablevels.o +${GRASP}/bin/rseqhfs: rseqhfs.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rtabtransE1: rtabtransE1.o - $(FC) -o $(BIN)/rtabtransE1 rtabtransE1.o +${GRASP}/bin/rseqtrans: rseqtrans.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/format_mix : format_mix.o - $(FC) -o $(BIN)/format_mix $(FC_LD) -L$(LIBDIR) \ - format_mix.o +${GRASP}/bin/rtabhfs: rtabhfs.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rmixextract: rmixextract.o - $(FC) -o $(BIN)/rmixextract $(FC_LD) rmixextract.o $(APP_LIBS) +${GRASP}/bin/rtablevels: rtablevels.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rcsfblock: rcsfblock.o - $(FC) -o $(BIN)/rcsfblock $(FC_LD) rcsfblock.o $(APP_LIBS) +${GRASP}/bin/rtabtrans1: rtabtrans1.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rwfnmchfmcdf: rwfnmchfmcdf.o - $(FC) -o $(BIN)/rwfnmchfmcdf $(FC_LD) rwfnmchfmcdf.o $(APP_LIBS) +${GRASP}/bin/rtabtrans2: rtabtrans2.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rlevels: rlevels.o - $(FC) -o $(BIN)/rlevels $(FC_LD) rlevels.o $(APP_LIBS) +${GRASP}/bin/rtabtransE1: rtabtransE1.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rtabtrans1: rtabtrans1.o - $(FC) -o $(BIN)/rtabtrans1 $(FC_LD) rtabtrans1.o $(APP_LIBS) +${GRASP}/bin/rwfnmchfmcdf: rwfnmchfmcdf.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rlevelsj: rlevelsj.o - $(FC) -o $(BIN)/rlevelsj $(FC_LD) rlevelsj.o $(APP_LIBS) +${GRASP}/bin/rwfnplot: rwfnplot.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rwfnplot: rwfnplot.o - $(FC) -o $(BIN)/rwfnplot rwfnplot.o +${GRASP}/bin/rwfnrelabel: rwfnrelabel.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rtabtrans2: rtabtrans2.o - $(FC) -o $(BIN)/rtabtrans2 rtabtrans2.o +${GRASP}/bin/rwfnrotate: rwfnrotate.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rlevelseV: rlevelseV.o - $(FC) -o $(BIN)/rlevelseV $(FC_LD) rlevelseV.o $(APP_LIBS) +${GRASP}/bin/wfnplot: wfnplot.o + $(FC) -o $@ $? $(FC_LD) $(LIBS) $(LAPACK_LIBS) -$(BIN)/rtabhfs: rtabhfs.o - $(FC) -o $(BIN)/rtabhfs rtabhfs.o - -$(BIN)/wfnplot: wfnplot.o - $(FC) -o $(BIN)/wfnplot wfnplot.o - -$(BIN)/rwfnrotate: rwfnrotate.o - $(FC) -o $(BIN)/rwfnrotate $(FC_LD) rwfnrotate.o $(APP_LIBS) - -$(BIN)/rwfnrelabel: rwfnrelabel.o - $(FC) -o $(BIN)/rwfnrelabel $(FC_LD) rwfnrelabel.o $(APP_LIBS) - -$(BIN)/rhfs_lsj: rhfs_lsj.o - $(FC) -o $(BIN)/rhfs_lsj $(FC_LD) rhfs_lsj.o $(APPS_LIBS) - -$(BIN)/rcsfmr: rcsfmr.o - $(FC) -o $(BIN)/rcsfmr $(FC_LD) rcsfmr.o $(APPS_LIBS) - - -.f90.o: - $(FC) -c $(FC_FLAGS) $< -I $(MODDIR) -I ${MODL9290} -I $(MODDIR) -o $@ +%.o: %.f90 + $(FC) -c $(FC_FLAGS) $(FC_MODULES) -o $@ $< clean: - -rm -f *.o core *.mod + -rm -f ${GRASP}/bin/lscomp.pl ${GRASP}/bin/rsave ${GRASP}/bin/rasfsplit ${GRASP}/bin/rcsfblock ${GRASP}/bin/rcsfmr ${GRASP}/bin/rcsfsplit ${GRASP}/bin/rhfs_lsj ${GRASP}/bin/rlevelseV ${GRASP}/bin/rlevels ${GRASP}/bin/rmixaccumulate ${GRASP}/bin/rmixextract ${GRASP}/bin/rseqenergy ${GRASP}/bin/rseqhfs ${GRASP}/bin/rseqtrans ${GRASP}/bin/rtabhfs ${GRASP}/bin/rtablevels ${GRASP}/bin/rtabtrans1 ${GRASP}/bin/rtabtrans2 ${GRASP}/bin/rtabtransE1 ${GRASP}/bin/rwfnmchfmcdf ${GRASP}/bin/rwfnplot ${GRASP}/bin/rwfnrelabel ${GRASP}/bin/rwfnrotate ${GRASP}/bin/wfnplot + -rm -f *.o *.mod diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt new file mode 100644 index 000000000..1ceff137a --- /dev/null +++ b/test/CMakeLists.txt @@ -0,0 +1,14 @@ +# Make sure the test executables end up on build/test/, not build/bin/ +unset(CMAKE_RUNTIME_OUTPUT_DIRECTORY) + +# Let's catch implicit uses of routines in the test prorams and libraries +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Werror=implicit-interface -Werror=implicit-procedure") + +# Check lib92 routines -- this currently acts as a simple integration test, +# making sure that everything actually got compiled properly. The test checks +# that the QUAD routine from lib92 actually produces reasonable numbers. +add_executable(test.lib9290_quad + lib9290_quad.f90 +) +target_link_libraries_Fortran(test.lib9290_quad PUBLIC mod 9290) +add_test(lib9290_quad test.lib9290_quad) diff --git a/test/lib9290_quad.f90 b/test/lib9290_quad.f90 new file mode 100644 index 000000000..3062e13ad --- /dev/null +++ b/test/lib9290_quad.f90 @@ -0,0 +1,54 @@ +program lib9290_quad + implicit none + + call setup + call runtest + +contains + + subroutine runtest + use parameter_def + use grid_C + use tatb_C + use quad_I + + real*8 :: real64_kind_ + integer, parameter :: real64 = kind(real64_kind_) + integer, parameter :: dp = real64 + + integer :: i + real(real64) :: result + + ! Integrate exp(-2x) from 0 to infinity. Expected result is 1/2. + do i = 1, NNN1 + TA(i) = exp(-2*R(i)) * RP(i) + end do + call quad(result) + + print *, "RESULT from QUAD", result + print *, "expected ", 0.5_dp + print *, "difference ", abs(result - 0.5_dp) + + if(abs(result - 0.5_dp) > 1e-12_dp) then + stop 1 + end if + end subroutine runtest + + subroutine setup + use parameter_def + use grid_C + use tatb_C + use setqic_I + use radgrd_I + + H = 5.0D-2 + RNT = 2.0D-6 + HP = 0.0D0 + N = NNNP + MTP = NNNP + + call setqic + call radgrd + end subroutine setup + +end program lib9290_quad From dd260f971134c214cf5569b0e29e906682d24ccb Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Wed, 29 Jan 2020 11:07:07 +1300 Subject: [PATCH 13/57] Don't run GitHub Actions on: pull_request (#35) on: [pull_request, push] creates two identical build jobs on a pull request. --- .github/workflows/buildfiles.yml | 2 +- .github/workflows/buildmake.yml | 2 +- .github/workflows/test.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/buildfiles.yml b/.github/workflows/buildfiles.yml index ad0658e62..0b4c4390b 100644 --- a/.github/workflows/buildfiles.yml +++ b/.github/workflows/buildfiles.yml @@ -1,6 +1,6 @@ name: Verify build files -on: [push, pull_request] +on: push jobs: build: diff --git a/.github/workflows/buildmake.yml b/.github/workflows/buildmake.yml index 7da7d76f4..6b452eeb6 100644 --- a/.github/workflows/buildmake.yml +++ b/.github/workflows/buildmake.yml @@ -1,6 +1,6 @@ name: Build with Make -on: [push, pull_request] +on: push jobs: build: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 71ca1f35b..631326426 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -1,6 +1,6 @@ name: Tests -on: [push, pull_request] +on: push jobs: build: From 42029dc7f55069b86d5bf8ce18e2eda33d9b4cc8 Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Wed, 29 Jan 2020 11:18:59 +1300 Subject: [PATCH 14/57] lib9290: User ERROR STOP instead of STOP in CONVRT (#34) If the string passed to CONVRT is not long enough, it terminates the program, which is an error condition. This should terminate with ERROR STOP so that (1) we'd get a non-zero exit code, and (2) we'd get a stacktrace to help identify where the crash occurred. --- src/lib/lib9290/convrt.f90 | 2 +- src/lib/lib9290/convrt2.f90 | 2 +- src/lib/lib9290/convrt_double.f90 | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lib/lib9290/convrt.f90 b/src/lib/lib9290/convrt.f90 index 14d9c88c7..6e0ad3b5c 100644 --- a/src/lib/lib9290/convrt.f90 +++ b/src/lib/lib9290/convrt.f90 @@ -44,7 +44,7 @@ SUBROUTINE CONVRT(INTNUM, CNUM, LENTH) ! IF (LENTH > LEN(CNUM)) THEN WRITE (6, *) 'CONVRT: Length of CNUM inadeuate.' - STOP + ERROR STOP ELSE IF (LENTH <= 9) THEN FORM = '(1I'//C19(LENTH)//')' diff --git a/src/lib/lib9290/convrt2.f90 b/src/lib/lib9290/convrt2.f90 index a60cf3ee3..b0335ec64 100644 --- a/src/lib/lib9290/convrt2.f90 +++ b/src/lib/lib9290/convrt2.f90 @@ -49,7 +49,7 @@ SUBROUTINE CONVRT2(INTNUM, CNUM, LENTH, FROM) ! IF (LENTH > LEN(CNUM)) THEN WRITE (ISTDE, *) 'CONVRT: Length of CNUM inadeuate. (from:', FROM, ')' - STOP + ERROR STOP ELSE IF (LENTH <= 9) THEN FORM = '(1I'//C19(LENTH)//')' diff --git a/src/lib/lib9290/convrt_double.f90 b/src/lib/lib9290/convrt_double.f90 index 3b6a32d72..108e248b1 100644 --- a/src/lib/lib9290/convrt_double.f90 +++ b/src/lib/lib9290/convrt_double.f90 @@ -52,7 +52,7 @@ SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) ! IF (LENTH > LEN(CNUM)) THEN WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' - STOP + ERROR STOP ELSE IF (LENTH <= 9) THEN FORM = '(1I'//C19(LENTH)//')' @@ -64,7 +64,7 @@ SUBROUTINE CONVRT_DOUBLE(INTNUM, CNUM, LENTH) IF(mod(INTNUM,2) /= 0) THEN IF (LENTH+2 > LEN(CNUM)) THEN WRITE (6, *) 'CONVRT_DOUBLE: Length of CNUM inadeuate.' - STOP + ERROR STOP ELSE CNUM(1:LENTH+2) = CNUM(1:LENTH)//'/2' LENTH = LENTH + 2 From e72054b748c6621c392f8ab8955d9d5db4b06f21 Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Mon, 3 Feb 2020 15:18:35 +1300 Subject: [PATCH 15/57] Slightly simplify the Makefile system (#30) * Create a root Makefile that builds everything Each library and program still has their own separate Makefile which depends on variables set by the root Makefile. The environment scripts are no longer necessary -- the variables can be overriden in Make.user. However, it should be noted that if variables like FC are set as an environment variable, they will still override the defaults. --- .github/workflows/buildmake.yml | 4 +-- .gitignore | 5 ++- Makefile | 56 +++++++++++++++++++++++++++++++++ README.md | 47 +++++++++++++++++++++++---- make_environment_gfortran | 29 ----------------- make_environment_ifort | 29 ----------------- src/Makefile | 26 --------------- src/appl/Makefile | 24 -------------- src/lib/Makefile | 22 ------------- 9 files changed, 102 insertions(+), 140 deletions(-) create mode 100644 Makefile delete mode 100755 make_environment_gfortran delete mode 100755 make_environment_ifort delete mode 100644 src/Makefile delete mode 100644 src/appl/Makefile delete mode 100644 src/lib/Makefile diff --git a/.github/workflows/buildmake.yml b/.github/workflows/buildmake.yml index 6b452eeb6..89aa29b8a 100644 --- a/.github/workflows/buildmake.yml +++ b/.github/workflows/buildmake.yml @@ -12,8 +12,6 @@ jobs: - name: "Install dependencies" run: sudo apt-get install -y build-essential gfortran liblapack-dev libblas-dev openmpi-bin openmpi-common libopenmpi-dev - name: Build GRASP - run: | - source make_environment_gfortran - cd src/ && make + run: make - name: Verify binaries run: ./contrib/checkbin.sh diff --git a/.gitignore b/.gitignore index 5123c8abf..70d1d9487 100644 --- a/.gitignore +++ b/.gitignore @@ -6,10 +6,13 @@ /lib/* !/lib/.gitkeep +# Ignore user build configuration files +CMakeLists.user +Make.user + # Ignore generated CMake files build/ build-*/ -CMakeLists.user # Ignore output log files *.out diff --git a/Makefile b/Makefile new file mode 100644 index 000000000..0f8be2f5e --- /dev/null +++ b/Makefile @@ -0,0 +1,56 @@ +# Determine the location of the root of the repository +export GRASP := $(abspath $(dir $(lastword $(MAKEFILE_LIST)))) + +# If present, load the Make.user file which may contain user-defined overrides +# to environment variables. +MAKE_USER_FILE := $(GRASP)/Make.user +ifeq (exists, $(shell [ -e $(MAKE_USER_FILE) ] && echo exists )) +include $(MAKE_USER_FILE) +endif + +# Variables affecting the GRASP build. These can be overridden in Make.user or via +# environment variables. +export FC_FLAGS ?= -O2 -fno-automatic +export FC_LD ?= +export FC_MPI ?= mpifort +export LAPACK_LIBS ?= -llapack -lblas +export FC_MPIFLAGS ?= $(FC_FLAGS) +export FC_MPILD ?= $(FC_LD) + +LIBRARIES = libmod lib9290 libdvd90 libmcp90 librang90 mpi90 +APPLICATIONS = HF jjgen90 rangular90 rbiotransform90 rci90 rcsfgenerate90 \ + rcsfzerofirst90 rmcdhf90 rnucleus90 rtransition90_mpi sms90 jj2lsj90 \ + rangular90_mpi rbiotransform90_mpi rci90_mpi rcsfinteract90 rhfs90 \ + rmcdhf90_mpi rtransition90 rwfnestimate90 + +LIBRARY_TARGETS = $(foreach library,$(LIBRARIES),src/lib/$(library)) +APPLICATION_TARGETS = $(foreach application,$(APPLICATIONS),src/appl/$(application)) + +.PHONY: all lib appl tool $(LIBRARY_TARGETS) $(APPLICATION_TARGETS) +all: lib appl tool +appl: $(APPLICATION_TARGETS) +lib: $(LIBRARY_TARGETS) +$(LIBRARY_TARGETS): src/lib/%: + @echo "Building: $@" + $(MAKE) -C $@ +$(APPLICATION_TARGETS): src/appl/%: lib + @echo "Building: $@" + $(MAKE) -C $@ +tool: lib + @echo "Building: src/tool" + $(MAKE) -C src/tool + +LIBRARY_CLEAN_TARGETS = $(foreach library,$(LIBRARIES),clean/lib/$(library)) +APPLICATION_CLEAN_TARGETS = $(foreach application,$(APPLICATIONS),clean/appl/$(application)) +.PHONY: clean clean/lib clean/appl clean/tool $(LIBRARY_CLEAN_TARGETS) $(APPLICATION_CLEAN_TARGETS) +clean: clean/lib clean/appl clean/tool $(LIBRARY_CLEAN_TARGETS) $(APPLICATION_CLEAN_TARGETS) +clean/lib: $(LIBRARY_CLEAN_TARGETS) + rm -vf $(GRASP)/lib/*.a +$(LIBRARY_CLEAN_TARGETS): clean/lib/%: + $(MAKE) -C src/lib/$* clean +clean/appl: $(APPLICATION_CLEAN_TARGETS) + rm -vf $(GRASP)/bin/* +$(APPLICATION_CLEAN_TARGETS): clean/appl/%: + $(MAKE) -C src/appl/$* clean +clean/tool: + $(MAKE) -C src/tool clean diff --git a/README.md b/README.md index c8c32973f..224526d6d 100644 --- a/README.md +++ b/README.md @@ -72,22 +72,57 @@ Remarks: ### `Makefile`-based build -The legacy `Makefile`-based build can be performed by first loading the necessary -environment variables (which may have to be modified to suit your system). E.g.: +The legacy `Makefile`-based build can be performed by simply calling the `make` in the top +level directory: ```sh -source make_environment_gfortran +make ``` -To actually build the binaries, you have to call `make` on the root `Makefile` in `src/`: +In this case, the compilation of each of the libraries and programs happens in their +respective directory under `src/` and the build artifacts are stored in the source tree. +The resulting binaries and libraries will directly get installed under the `bin/` and `lib/` +directories. -``` -cd src/ && make +To build a specific library or binary you can pass the path to the source directory as the +Make target: + +```sh +# build libmod +make src/lib/libmod +# build the rci_mpi binary +make src/appl/rci90_mpi ``` +Note that any necessary library dependencies will also get built automatically. + **WARNING:** the `Makefile`s do not know about the dependencies between the source files, so parallel builds (i.e. calling `make` with the `-j` option) does not work. +#### Customizing the build + +By default the `Makefile` is designed to use `gfortran`. The variables affecting GRASP +builds are defined and documented at the beginning of the `Makefile`. + +For the user it should never be necessary to modify the `Makefile` itself. Rather, a +`Make.user` file can be create next to the main `Makefile` where the build variables can be +overridden. E.g. to use the Intel Fortran compiler instead, you may want to create the +following `Make.user` file: + +```make +export FC = ifort +export FC_FLAGS = -O2 -save +export FC_LD = -mkl=sequential +export FC_MPI = mpiifort +``` + +As another example, to set up a linker search path for the BLAS or LAPACK libraries, you can +set up `Make.user` as follows: + +```make +export FC_LD = -L /path/to/blas +``` + ## About GRASP This version of GRASP is a major revision of the previous GRASP2K package by [P. diff --git a/make_environment_gfortran b/make_environment_gfortran deleted file mode 100755 index 16caba378..000000000 --- a/make_environment_gfortran +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/bash -# ------------------------------------------------------------------------------------------------------------------- -# GRASP ENVIRONMENT FLAGS - GNU gfortran version -# ------------------------------------------------------------------------------------------------------------------- -# -# Define the following global variables according to your environment and -# source this script or add these definitions to your terminal configuration -# file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. -# -# Installation requirements: -# - Lapack, Blas and MPI libraries have to be installed and properly linked - e.g. add them to LD_LIBRARY_PATH. -# - The Fortran compiler of choice and the MPI wrapper (as specified by FC and FC_MPI below) have to be on your PATH. -# -# ------------------------------------------------------------------------------------------------------------------- -# Set up main flags -# ------------------------------------------------------------------------------------------------------------------- -export FC=gfortran # Fortran compiler -export FC_FLAGS="-O2 -fno-automatic " # Serial code compiler flags -export FC_LD=" " # Serial linker flags -export GRASP="${PWD}" # Location of the 2018 root directory -export LAPACK_LIBS="-llapack -lblas" # Lapack libraries -# ------------------------------------------------------------------------------------------------------------------- -# Set up MPI related flags -# ------------------------------------------------------------------------------------------------------------------- -export FC_MPI="mpifort" # MPI -export FC_MPIFLAGS="${FC_FLAGS}" # Parallel code compiler flags -export FC_MPILD=${FC_LD} # Serial linker flags -# ------------------------------------------------------------------------------------------------------------------- -export MPI_TMP="${HOME}/grasp_mpi_tmp" # Location for temporary files diff --git a/make_environment_ifort b/make_environment_ifort deleted file mode 100755 index de63b04b0..000000000 --- a/make_environment_ifort +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/bash -# ------------------------------------------------------------------------------------------------------------------- -# GRASP ENVIRONMENT FLAGS - Intel ifort version -# ------------------------------------------------------------------------------------------------------------------- -# -# Define the following global variables according to your environment and -# source this script or add these definitions to your terminal configuration -# file, eg. ~/.cshrc, ~/.bashrc or ~/.profile. -# -# Installation requirements: -# - Lapack, Blas and MPI libraries have to be installed and properly linked - e.g. add them to LD_LIBRARY_PATH. -# - The Fortran compiler of choice and the MPI wrapper (as specified by FC and FC_MPI below) have to be on your PATH. -# -# ------------------------------------------------------------------------------------------------------------------- -# Set up main flags -# ------------------------------------------------------------------------------------------------------------------- -export FC=ifort # Fortran compiler -export FC_FLAGS="-O2 -save " # Serial code compiler flags -export FC_LD="-mkl=sequential" # Serial linker flags -export GRASP="${PWD}" # Location of the 2018 root directory -export LAPACK_LIBS="-llapack -lblas" # Lapack libraries -# ------------------------------------------------------------------------------------------------------------------- -# Set up MPI related flags -# ------------------------------------------------------------------------------------------------------------------- -export FC_MPI="mpiifort" # MPI -export FC_MPIFLAGS="${FC_FLAGS}" # Parallel code compiler flags -export FC_MPILD=${FC_LD} # Serial linker flags -# ------------------------------------------------------------------------------------------------------------------- -export MPI_TMP="${HOME}/grasp_mpi_tmp" # Location for temporary files diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index e661a05d9..000000000 --- a/src/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -SUBDIR = lib appl tool -TARGETS = install -MKDIR = ${GRASP} ${GRASP}/bin ${GRASP}/lib - -$(TARGETS): - @for D in $(MKDIR) ; \ - do \ - test -d $$D || echo ... creating a new directory $$D... ; \ - test -d $$D || mkdir $$D ; \ - done - @for i in $(SUBDIR) ;\ - do \ - cd $$i ; \ - echo "....Entering: $$i" ; \ - $(MAKE); \ - cd .. ; \ - echo "....Leaving: $$i" ; echo; echo;\ - done -clean : - @for i in $(SUBDIR) ;\ - do \ - echo "Current directory: $$i" ; \ - cd $$i ; \ - make clean; \ - cd .. ; \ - done diff --git a/src/appl/Makefile b/src/appl/Makefile deleted file mode 100644 index 019667fa7..000000000 --- a/src/appl/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -SUBDIR = HF jj2lsj90 jjgen90 rangular90 rbiotransform90 rci90 rcsfgenerate90 \ - rcsfinteract90 rcsfzerofirst90 rhfs90 rmcdhf90 rnucleus90 rtransition90 rwfnestimate90 sms90 \ - rangular90_mpi rbiotransform90_mpi rci90_mpi rmcdhf90_mpi rtransition90_mpi - -TARGETS = install - -$(TARGETS): - @for i in $(SUBDIR) ;\ - do \ - echo "Current directory: $$i" ; \ - cd $$i ; \ - make; \ -echo "....Leaving: $$i" ; echo; echo;\ - cd .. ; \ - done - -clean : - @for i in $(SUBDIR) ;\ - do \ - echo "Current directory: $$i" ; \ - cd $$i ; \ - make clean; \ - cd .. ; \ - done diff --git a/src/lib/Makefile b/src/lib/Makefile deleted file mode 100644 index e6bb6c879..000000000 --- a/src/lib/Makefile +++ /dev/null @@ -1,22 +0,0 @@ - - -SUBDIR = libmod lib9290 libmcp90 librang90 mpi90 libdvd90 -TARGETS = install - -$(TARGETS): - @for i in $(SUBDIR) ;\ - do \ - echo "Current directory: $$i" ; \ - cd $$i ; \ - make; \ -echo "....Leaving: $$i" ; echo; echo;\ - cd .. ; \ - done -clean: - @for i in $(SUBDIR) ;\ - do \ - echo "Current directory: $$i" ; \ - cd $$i ; \ - $(MAKE) $@ ; \ - cd .. ; \ - done From 80fb38d36b086fea81041ba2662a14b174e9e77d Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Mon, 10 Feb 2020 19:47:47 +1300 Subject: [PATCH 16/57] Set minimum CMake to 3.6 (#38) Not because it is strictly necessary, but because it is the lowest one that has been tested. --- CMakeLists.txt | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 3bf7a1689..82a5de312 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -10,7 +10,14 @@ # which will compile and install all the libraries to lib/ # -cmake_minimum_required(VERSION 2.6) +# This minimum CMake requirement can probably be loosened. But GRASP has not +# been tested with CMake versions older than 3.6.3. +# +# This particular minimum version is necessary as it is the lowest one which +# ships with a FindBLAS module that is able to detect OpenBLAS loaded with +# Environment Modules. +cmake_minimum_required(VERSION 3.6) + project(grasp) enable_language(Fortran) From d161e0c3e3a23223f5a3aea9c392eec266d5d0a0 Mon Sep 17 00:00:00 2001 From: Morten Piibeleht Date: Mon, 17 Feb 2020 16:43:00 +1300 Subject: [PATCH 17/57] Add Doxygen (#40) --- .github/workflows/documentation.yml | 20 + .gitignore | 3 + Doxyfile | 2427 +++++++++++++++++++++++++++ README.md | 5 + contrib/deploydocs.sh | 60 + contrib/makedocs.sh | 16 + doc/doxygen.md | 4 + 7 files changed, 2535 insertions(+) create mode 100644 .github/workflows/documentation.yml create mode 100644 Doxyfile create mode 100755 contrib/deploydocs.sh create mode 100755 contrib/makedocs.sh create mode 100644 doc/doxygen.md diff --git a/.github/workflows/documentation.yml b/.github/workflows/documentation.yml new file mode 100644 index 000000000..45ae45e90 --- /dev/null +++ b/.github/workflows/documentation.yml @@ -0,0 +1,20 @@ +name: Documentation + +on: push + +jobs: + build: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + - name: "Install dependencies" + run: sudo apt-get install -y doxygen graphviz + - name: Build documentation + run: ./contrib/makedocs.sh + - name: Deploy documentation + if: github.event_name == 'push' && github.ref == 'refs/heads/master' + env: # Set the secret as an input + GITHUB_DEPLOY_KEY: ${{ secrets.GITHUB_DEPLOY_KEY }} + run: ./contrib/deploydocs.sh diff --git a/.gitignore b/.gitignore index 70d1d9487..0142b9bc2 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,9 @@ Make.user build/ build-*/ +# Ignore Doxygen-generated files +/doc/html + # Ignore output log files *.out *.err diff --git a/Doxyfile b/Doxyfile new file mode 100644 index 000000000..622d9c4f5 --- /dev/null +++ b/Doxyfile @@ -0,0 +1,2427 @@ +# Doxyfile 1.8.11 + +# This file describes the settings to be used by the documentation system +# doxygen (www.doxygen.org) for a project. +# +# All text after a double hash (##) is considered a comment and is placed in +# front of the TAG it is preceding. +# +# All text after a single hash (#) is considered a comment and will be ignored. +# The format is: +# TAG = value [value, ...] +# For lists, items can also be appended using: +# TAG += value [value, ...] +# Values that contain spaces should be placed between quotes (\" \"). + +#--------------------------------------------------------------------------- +# Project related configuration options +#--------------------------------------------------------------------------- + +# This tag specifies the encoding used for all characters in the config file +# that follow. The default is UTF-8 which is also the encoding used for all text +# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv +# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv +# for the list of possible encodings. +# The default value is: UTF-8. + +DOXYFILE_ENCODING = UTF-8 + +# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by +# double-quotes, unless you are using Doxywizard) that should identify the +# project for which the documentation is generated. This name is used in the +# title of most generated pages and in a few other places. +# The default value is: My Project. + +PROJECT_NAME = "GRASP" + +# The PROJECT_NUMBER tag can be used to enter a project or revision number. This +# could be handy for archiving the generated documentation or if some version +# control system is used. + +PROJECT_NUMBER = + +# Using the PROJECT_BRIEF tag one can provide an optional one line description +# for a project that appears at the top of each page and should give viewer a +# quick idea about the purpose of the project. Keep the description short. + +PROJECT_BRIEF = + +# With the PROJECT_LOGO tag one can specify a logo or an icon that is included +# in the documentation. The maximum height of the logo should not exceed 55 +# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy +# the logo to the output directory. + +PROJECT_LOGO = + +# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path +# into which the generated documentation will be written. If a relative path is +# entered, it will be relative to the location where doxygen was started. If +# left blank the current directory will be used. + +OUTPUT_DIRECTORY = doc/ + +# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- +# directories (in 2 levels) under the output directory of each output format and +# will distribute the generated files over these directories. Enabling this +# option can be useful when feeding doxygen a huge amount of source files, where +# putting all generated files in the same directory would otherwise causes +# performance problems for the file system. +# The default value is: NO. + +CREATE_SUBDIRS = NO + +# If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII +# characters to appear in the names of generated files. If set to NO, non-ASCII +# characters will be escaped, for example _xE3_x81_x84 will be used for Unicode +# U+3044. +# The default value is: NO. + +ALLOW_UNICODE_NAMES = NO + +# The OUTPUT_LANGUAGE tag is used to specify the language in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all constant output in the proper language. +# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese, +# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States), +# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian, +# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages), +# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian, +# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian, +# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish, +# Ukrainian and Vietnamese. +# The default value is: English. + +OUTPUT_LANGUAGE = English + +# If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member +# descriptions after the members that are listed in the file and class +# documentation (similar to Javadoc). Set to NO to disable this. +# The default value is: YES. + +BRIEF_MEMBER_DESC = YES + +# If the REPEAT_BRIEF tag is set to YES, doxygen will prepend the brief +# description of a member or function before the detailed description +# +# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the +# brief descriptions will be completely suppressed. +# The default value is: YES. + +REPEAT_BRIEF = YES + +# This tag implements a quasi-intelligent brief description abbreviator that is +# used to form the text in various listings. Each string in this list, if found +# as the leading text of the brief description, will be stripped from the text +# and the result, after processing the whole list, is used as the annotated +# text. Otherwise, the brief description is used as-is. If left blank, the +# following values are used ($name is automatically replaced with the name of +# the entity):The $name class, The $name widget, The $name file, is, provides, +# specifies, contains, represents, a, an and the. + +ABBREVIATE_BRIEF = + +# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then +# doxygen will generate a detailed section even if there is only a brief +# description. +# The default value is: NO. + +ALWAYS_DETAILED_SEC = NO + +# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all +# inherited members of a class in the documentation of that class as if those +# members were ordinary class members. Constructors, destructors and assignment +# operators of the base classes will not be shown. +# The default value is: NO. + +INLINE_INHERITED_MEMB = NO + +# If the FULL_PATH_NAMES tag is set to YES, doxygen will prepend the full path +# before files name in the file list and in the header files. If set to NO the +# shortest path that makes the file name unique will be used +# The default value is: YES. + +FULL_PATH_NAMES = YES + +# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path. +# Stripping is only done if one of the specified strings matches the left-hand +# part of the path. The tag can be used to show relative paths in the file list. +# If left blank the directory from which doxygen is run is used as the path to +# strip. +# +# Note that you can specify absolute paths here, but also relative paths, which +# will be relative from the directory where doxygen is started. +# This tag requires that the tag FULL_PATH_NAMES is set to YES. + +STRIP_FROM_PATH = + +# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the +# path mentioned in the documentation of a class, which tells the reader which +# header file to include in order to use a class. If left blank only the name of +# the header file containing the class definition is used. Otherwise one should +# specify the list of include paths that are normally passed to the compiler +# using the -I flag. + +STRIP_FROM_INC_PATH = + +# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but +# less readable) file names. This can be useful is your file systems doesn't +# support long names like on DOS, Mac, or CD-ROM. +# The default value is: NO. + +SHORT_NAMES = NO + +# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the +# first line (until the first dot) of a Javadoc-style comment as the brief +# description. If set to NO, the Javadoc-style will behave just like regular Qt- +# style comments (thus requiring an explicit @brief command for a brief +# description.) +# The default value is: NO. + +JAVADOC_AUTOBRIEF = NO + +# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first +# line (until the first dot) of a Qt-style comment as the brief description. If +# set to NO, the Qt-style will behave just like regular Qt-style comments (thus +# requiring an explicit \brief command for a brief description.) +# The default value is: NO. + +QT_AUTOBRIEF = NO + +# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a +# multi-line C++ special comment block (i.e. a block of //! or /// comments) as +# a brief description. This used to be the default behavior. The new default is +# to treat a multi-line C++ comment block as a detailed description. Set this +# tag to YES if you prefer the old behavior instead. +# +# Note that setting this tag to YES also means that rational rose comments are +# not recognized any more. +# The default value is: NO. + +MULTILINE_CPP_IS_BRIEF = NO + +# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the +# documentation from any documented member that it re-implements. +# The default value is: YES. + +INHERIT_DOCS = YES + +# If the SEPARATE_MEMBER_PAGES tag is set to YES then doxygen will produce a new +# page for each member. If set to NO, the documentation of a member will be part +# of the file/class/namespace that contains it. +# The default value is: NO. + +SEPARATE_MEMBER_PAGES = NO + +# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen +# uses this value to replace tabs by spaces in code fragments. +# Minimum value: 1, maximum value: 16, default value: 4. + +TAB_SIZE = 4 + +# This tag can be used to specify a number of aliases that act as commands in +# the documentation. An alias has the form: +# name=value +# For example adding +# "sideeffect=@par Side Effects:\n" +# will allow you to put the command \sideeffect (or @sideeffect) in the +# documentation, which will result in a user-defined paragraph with heading +# "Side Effects:". You can put \n's in the value part of an alias to insert +# newlines. + +ALIASES = + +# This tag can be used to specify a number of word-keyword mappings (TCL only). +# A mapping has the form "name=value". For example adding "class=itcl::class" +# will allow you to use the command class in the itcl::class meaning. + +TCL_SUBST = + +# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources +# only. Doxygen will then generate output that is more tailored for C. For +# instance, some of the names that are used will be different. The list of all +# members will be omitted, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_FOR_C = NO + +# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or +# Python sources only. Doxygen will then generate output that is more tailored +# for that language. For instance, namespaces will be presented as packages, +# qualified scopes will look different, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_JAVA = NO + +# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran +# sources. Doxygen will then generate output that is tailored for Fortran. +# The default value is: NO. + +OPTIMIZE_FOR_FORTRAN = YES + +# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL +# sources. Doxygen will then generate output that is tailored for VHDL. +# The default value is: NO. + +OPTIMIZE_OUTPUT_VHDL = NO + +# Doxygen selects the parser to use depending on the extension of the files it +# parses. With this tag you can assign which parser to use for a given +# extension. Doxygen has a built-in mapping, but you can override or extend it +# using this tag. The format is ext=language, where ext is a file extension, and +# language is one of the parsers supported by doxygen: IDL, Java, Javascript, +# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran: +# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran: +# Fortran. In the later case the parser tries to guess whether the code is fixed +# or free formatted code, this is the default for Fortran type files), VHDL. For +# instance to make doxygen treat .inc files as Fortran files (default is PHP), +# and .f files as C (default is Fortran), use: inc=Fortran f=C. +# +# Note: For files without extension you can use no_extension as a placeholder. +# +# Note that for custom extensions you also need to set FILE_PATTERNS otherwise +# the files are not read by doxygen. + +EXTENSION_MAPPING = f=FortranFixed f90=FortranFree + +# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments +# according to the Markdown format, which allows for more readable +# documentation. See http://daringfireball.net/projects/markdown/ for details. +# The output of markdown processing is further processed by doxygen, so you can +# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in +# case of backward compatibilities issues. +# The default value is: YES. + +MARKDOWN_SUPPORT = YES + +# When enabled doxygen tries to link words that correspond to documented +# classes, or namespaces to their corresponding documentation. Such a link can +# be prevented in individual cases by putting a % sign in front of the word or +# globally by setting AUTOLINK_SUPPORT to NO. +# The default value is: YES. + +AUTOLINK_SUPPORT = YES + +# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want +# to include (a tag file for) the STL sources as input, then you should set this +# tag to YES in order to let doxygen match functions declarations and +# definitions whose arguments contain STL classes (e.g. func(std::string); +# versus func(std::string) {}). This also make the inheritance and collaboration +# diagrams that involve STL classes more complete and accurate. +# The default value is: NO. + +BUILTIN_STL_SUPPORT = NO + +# If you use Microsoft's C++/CLI language, you should set this option to YES to +# enable parsing support. +# The default value is: NO. + +CPP_CLI_SUPPORT = NO + +# Set the SIP_SUPPORT tag to YES if your project consists of sip (see: +# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen +# will parse them like normal C++ but will assume all classes use public instead +# of private inheritance when no explicit protection keyword is present. +# The default value is: NO. + +SIP_SUPPORT = NO + +# For Microsoft's IDL there are propget and propput attributes to indicate +# getter and setter methods for a property. Setting this option to YES will make +# doxygen to replace the get and set methods by a property in the documentation. +# This will only work if the methods are indeed getting or setting a simple +# type. If this is not the case, or you want to show the methods anyway, you +# should set this option to NO. +# The default value is: YES. + +IDL_PROPERTY_SUPPORT = YES + +# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC +# tag is set to YES then doxygen will reuse the documentation of the first +# member in the group (if any) for the other members of the group. By default +# all members of a group must be documented explicitly. +# The default value is: NO. + +DISTRIBUTE_GROUP_DOC = NO + +# If one adds a struct or class to a group and this option is enabled, then also +# any nested class or struct is added to the same group. By default this option +# is disabled and one has to add nested compounds explicitly via \ingroup. +# The default value is: NO. + +GROUP_NESTED_COMPOUNDS = NO + +# Set the SUBGROUPING tag to YES to allow class member groups of the same type +# (for instance a group of public functions) to be put as a subgroup of that +# type (e.g. under the Public Functions section). Set it to NO to prevent +# subgrouping. Alternatively, this can be done per class using the +# \nosubgrouping command. +# The default value is: YES. + +SUBGROUPING = YES + +# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions +# are shown inside the group in which they are included (e.g. using \ingroup) +# instead of on a separate page (for HTML and Man pages) or section (for LaTeX +# and RTF). +# +# Note that this feature does not work in combination with +# SEPARATE_MEMBER_PAGES. +# The default value is: NO. + +INLINE_GROUPED_CLASSES = NO + +# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions +# with only public data fields or simple typedef fields will be shown inline in +# the documentation of the scope in which they are defined (i.e. file, +# namespace, or group documentation), provided this scope is documented. If set +# to NO, structs, classes, and unions are shown on a separate page (for HTML and +# Man pages) or section (for LaTeX and RTF). +# The default value is: NO. + +INLINE_SIMPLE_STRUCTS = NO + +# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or +# enum is documented as struct, union, or enum with the name of the typedef. So +# typedef struct TypeS {} TypeT, will appear in the documentation as a struct +# with name TypeT. When disabled the typedef will appear as a member of a file, +# namespace, or class. And the struct will be named TypeS. This can typically be +# useful for C code in case the coding convention dictates that all compound +# types are typedef'ed and only the typedef is referenced, never the tag name. +# The default value is: NO. + +TYPEDEF_HIDES_STRUCT = NO + +# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This +# cache is used to resolve symbols given their name and scope. Since this can be +# an expensive process and often the same symbol appears multiple times in the +# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small +# doxygen will become slower. If the cache is too large, memory is wasted. The +# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range +# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536 +# symbols. At the end of a run doxygen will report the cache usage and suggest +# the optimal cache size from a speed point of view. +# Minimum value: 0, maximum value: 9, default value: 0. + +LOOKUP_CACHE_SIZE = 0 + +#--------------------------------------------------------------------------- +# Build related configuration options +#--------------------------------------------------------------------------- + +# If the EXTRACT_ALL tag is set to YES, doxygen will assume all entities in +# documentation are documented, even if no documentation was available. Private +# class members and static file members will be hidden unless the +# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES. +# Note: This will also disable the warnings about undocumented members that are +# normally produced when WARNINGS is set to YES. +# The default value is: NO. + +EXTRACT_ALL = YES + +# If the EXTRACT_PRIVATE tag is set to YES, all private members of a class will +# be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIVATE = YES + +# If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal +# scope will be included in the documentation. +# The default value is: NO. + +EXTRACT_PACKAGE = NO + +# If the EXTRACT_STATIC tag is set to YES, all static members of a file will be +# included in the documentation. +# The default value is: NO. + +EXTRACT_STATIC = YES + +# If the EXTRACT_LOCAL_CLASSES tag is set to YES, classes (and structs) defined +# locally in source files will be included in the documentation. If set to NO, +# only classes defined in header files are included. Does not have any effect +# for Java sources. +# The default value is: YES. + +EXTRACT_LOCAL_CLASSES = YES + +# This flag is only useful for Objective-C code. If set to YES, local methods, +# which are defined in the implementation section but not in the interface are +# included in the documentation. If set to NO, only methods in the interface are +# included. +# The default value is: NO. + +EXTRACT_LOCAL_METHODS = NO + +# If this flag is set to YES, the members of anonymous namespaces will be +# extracted and appear in the documentation as a namespace called +# 'anonymous_namespace{file}', where file will be replaced with the base name of +# the file that contains the anonymous namespace. By default anonymous namespace +# are hidden. +# The default value is: NO. + +EXTRACT_ANON_NSPACES = NO + +# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all +# undocumented members inside documented classes or files. If set to NO these +# members will be included in the various overviews, but no documentation +# section is generated. This option has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_MEMBERS = NO + +# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all +# undocumented classes that are normally visible in the class hierarchy. If set +# to NO, these classes will be included in the various overviews. This option +# has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_CLASSES = NO + +# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend +# (class|struct|union) declarations. If set to NO, these declarations will be +# included in the documentation. +# The default value is: NO. + +HIDE_FRIEND_COMPOUNDS = NO + +# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any +# documentation blocks found inside the body of a function. If set to NO, these +# blocks will be appended to the function's detailed documentation block. +# The default value is: NO. + +HIDE_IN_BODY_DOCS = NO + +# The INTERNAL_DOCS tag determines if documentation that is typed after a +# \internal command is included. If the tag is set to NO then the documentation +# will be excluded. Set it to YES to include the internal documentation. +# The default value is: NO. + +INTERNAL_DOCS = NO + +# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file +# names in lower-case letters. If set to YES, upper-case letters are also +# allowed. This is useful if you have classes or files whose names only differ +# in case and if your file system supports case sensitive file names. Windows +# and Mac users are advised to set this option to NO. +# The default value is: system dependent. + +CASE_SENSE_NAMES = YES + +# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with +# their full class and namespace scopes in the documentation. If set to YES, the +# scope will be hidden. +# The default value is: NO. + +HIDE_SCOPE_NAMES = NO + +# If the HIDE_COMPOUND_REFERENCE tag is set to NO (default) then doxygen will +# append additional text to a page's title, such as Class Reference. If set to +# YES the compound reference will be hidden. +# The default value is: NO. + +HIDE_COMPOUND_REFERENCE= NO + +# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of +# the files that are included by a file in the documentation of that file. +# The default value is: YES. + +SHOW_INCLUDE_FILES = YES + +# If the SHOW_GROUPED_MEMB_INC tag is set to YES then Doxygen will add for each +# grouped member an include statement to the documentation, telling the reader +# which file to include in order to use the member. +# The default value is: NO. + +SHOW_GROUPED_MEMB_INC = NO + +# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include +# files with double quotes in the documentation rather than with sharp brackets. +# The default value is: NO. + +FORCE_LOCAL_INCLUDES = NO + +# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the +# documentation for inline members. +# The default value is: YES. + +INLINE_INFO = YES + +# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the +# (detailed) documentation of file and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. +# The default value is: YES. + +SORT_MEMBER_DOCS = YES + +# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief +# descriptions of file, namespace and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. Note that +# this will also influence the order of the classes in the class list. +# The default value is: NO. + +SORT_BRIEF_DOCS = NO + +# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the +# (brief and detailed) documentation of class members so that constructors and +# destructors are listed first. If set to NO the constructors will appear in the +# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS. +# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief +# member documentation. +# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting +# detailed member documentation. +# The default value is: NO. + +SORT_MEMBERS_CTORS_1ST = NO + +# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy +# of group names into alphabetical order. If set to NO the group names will +# appear in their defined order. +# The default value is: NO. + +SORT_GROUP_NAMES = NO + +# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by +# fully-qualified names, including namespaces. If set to NO, the class list will +# be sorted only by class name, not including the namespace part. +# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES. +# Note: This option applies only to the class list, not to the alphabetical +# list. +# The default value is: NO. + +SORT_BY_SCOPE_NAME = NO + +# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper +# type resolution of all parameters of a function it will reject a match between +# the prototype and the implementation of a member function even if there is +# only one candidate or it is obvious which candidate to choose by doing a +# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still +# accept a match between prototype and implementation in such cases. +# The default value is: NO. + +STRICT_PROTO_MATCHING = NO + +# The GENERATE_TODOLIST tag can be used to enable (YES) or disable (NO) the todo +# list. This list is created by putting \todo commands in the documentation. +# The default value is: YES. + +GENERATE_TODOLIST = YES + +# The GENERATE_TESTLIST tag can be used to enable (YES) or disable (NO) the test +# list. This list is created by putting \test commands in the documentation. +# The default value is: YES. + +GENERATE_TESTLIST = YES + +# The GENERATE_BUGLIST tag can be used to enable (YES) or disable (NO) the bug +# list. This list is created by putting \bug commands in the documentation. +# The default value is: YES. + +GENERATE_BUGLIST = YES + +# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or disable (NO) +# the deprecated list. This list is created by putting \deprecated commands in +# the documentation. +# The default value is: YES. + +GENERATE_DEPRECATEDLIST= YES + +# The ENABLED_SECTIONS tag can be used to enable conditional documentation +# sections, marked by \if ... \endif and \cond +# ... \endcond blocks. + +ENABLED_SECTIONS = + +# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the +# initial value of a variable or macro / define can have for it to appear in the +# documentation. If the initializer consists of more lines than specified here +# it will be hidden. Use a value of 0 to hide initializers completely. The +# appearance of the value of individual variables and macros / defines can be +# controlled using \showinitializer or \hideinitializer command in the +# documentation regardless of this setting. +# Minimum value: 0, maximum value: 10000, default value: 30. + +MAX_INITIALIZER_LINES = 30 + +# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at +# the bottom of the documentation of classes and structs. If set to YES, the +# list will mention the files that were used to generate the documentation. +# The default value is: YES. + +SHOW_USED_FILES = YES + +# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This +# will remove the Files entry from the Quick Index and from the Folder Tree View +# (if specified). +# The default value is: YES. + +SHOW_FILES = YES + +# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces +# page. This will remove the Namespaces entry from the Quick Index and from the +# Folder Tree View (if specified). +# The default value is: YES. + +SHOW_NAMESPACES = YES + +# The FILE_VERSION_FILTER tag can be used to specify a program or script that +# doxygen should invoke to get the current version for each file (typically from +# the version control system). Doxygen will invoke the program by executing (via +# popen()) the command command input-file, where command is the value of the +# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided +# by doxygen. Whatever the program writes to standard output is used as the file +# version. For an example see the documentation. + +FILE_VERSION_FILTER = + +# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed +# by doxygen. The layout file controls the global structure of the generated +# output files in an output format independent way. To create the layout file +# that represents doxygen's defaults, run doxygen with the -l option. You can +# optionally specify a file name after the option, if omitted DoxygenLayout.xml +# will be used as the name of the layout file. +# +# Note that if you run doxygen from a directory containing a file called +# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE +# tag is left empty. + +LAYOUT_FILE = + +# The CITE_BIB_FILES tag can be used to specify one or more bib files containing +# the reference definitions. This must be a list of .bib files. The .bib +# extension is automatically appended if omitted. This requires the bibtex tool +# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info. +# For LaTeX the style of the bibliography can be controlled using +# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the +# search path. See also \cite for info how to create references. + +CITE_BIB_FILES = + +#--------------------------------------------------------------------------- +# Configuration options related to warning and progress messages +#--------------------------------------------------------------------------- + +# The QUIET tag can be used to turn on/off the messages that are generated to +# standard output by doxygen. If QUIET is set to YES this implies that the +# messages are off. +# The default value is: NO. + +QUIET = NO + +# The WARNINGS tag can be used to turn on/off the warning messages that are +# generated to standard error (stderr) by doxygen. If WARNINGS is set to YES +# this implies that the warnings are on. +# +# Tip: Turn warnings on while writing the documentation. +# The default value is: YES. + +WARNINGS = YES + +# If the WARN_IF_UNDOCUMENTED tag is set to YES then doxygen will generate +# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag +# will automatically be disabled. +# The default value is: YES. + +WARN_IF_UNDOCUMENTED = YES + +# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for +# potential errors in the documentation, such as not documenting some parameters +# in a documented function, or documenting parameters that don't exist or using +# markup commands wrongly. +# The default value is: YES. + +WARN_IF_DOC_ERROR = YES + +# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that +# are documented, but have no documentation for their parameters or return +# value. If set to NO, doxygen will only warn about wrong or incomplete +# parameter documentation, but not about the absence of documentation. +# The default value is: NO. + +WARN_NO_PARAMDOC = NO + +# If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when +# a warning is encountered. +# The default value is: NO. + +WARN_AS_ERROR = NO + +# The WARN_FORMAT tag determines the format of the warning messages that doxygen +# can produce. The string should contain the $file, $line, and $text tags, which +# will be replaced by the file and line number from which the warning originated +# and the warning text. Optionally the format may contain $version, which will +# be replaced by the version of the file (if it could be obtained via +# FILE_VERSION_FILTER) +# The default value is: $file:$line: $text. + +WARN_FORMAT = "$file:$line: $text" + +# The WARN_LOGFILE tag can be used to specify a file to which warning and error +# messages should be written. If left blank the output is written to standard +# error (stderr). + +WARN_LOGFILE = + +#--------------------------------------------------------------------------- +# Configuration options related to the input files +#--------------------------------------------------------------------------- + +# The INPUT tag is used to specify the files and/or directories that contain +# documented source files. You may enter file names like myfile.cpp or +# directories like /usr/src/myproject. Separate the files or directories with +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING +# Note: If this tag is empty the current directory is searched. + +INPUT = README.md LICENSE.md doc/ src/ + +# This tag can be used to specify the character encoding of the source files +# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses +# libiconv (or the iconv built into libc) for the transcoding. See the libiconv +# documentation (see: http://www.gnu.org/software/libiconv) for the list of +# possible encodings. +# The default value is: UTF-8. + +INPUT_ENCODING = UTF-8 + +# If the value of the INPUT tag contains directories, you can use the +# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and +# *.h) to filter out the source-files in the directories. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# read by doxygen. +# +# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, +# *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, +# *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, +# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f, *.for, *.tcl, +# *.vhd, *.vhdl, *.ucf, *.qsf, *.as and *.js. + +FILE_PATTERNS = + +# The RECURSIVE tag can be used to specify whether or not subdirectories should +# be searched for input files as well. +# The default value is: NO. + +RECURSIVE = YES + +# The EXCLUDE tag can be used to specify files and/or directories that should be +# excluded from the INPUT source files. This way you can easily exclude a +# subdirectory from a directory tree whose root is specified with the INPUT tag. +# +# Note that relative paths are relative to the directory from which doxygen is +# run. + +EXCLUDE = doc/html/ + +# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or +# directories that are symbolic links (a Unix file system feature) are excluded +# from the input. +# The default value is: NO. + +EXCLUDE_SYMLINKS = NO + +# If the value of the INPUT tag contains directories, you can use the +# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude +# certain files from those directories. +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories for example use the pattern */test/* + +EXCLUDE_PATTERNS = + +# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names +# (namespaces, classes, functions, etc.) that should be excluded from the +# output. The symbol name can be a fully qualified name, a word, or if the +# wildcard * is used, a substring. Examples: ANamespace, AClass, +# AClass::ANamespace, ANamespace::*Test +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories use the pattern */test/* + +EXCLUDE_SYMBOLS = + +# The EXAMPLE_PATH tag can be used to specify one or more files or directories +# that contain example code fragments that are included (see the \include +# command). + +EXAMPLE_PATH = + +# If the value of the EXAMPLE_PATH tag contains directories, you can use the +# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and +# *.h) to filter out the source-files in the directories. If left blank all +# files are included. + +EXAMPLE_PATTERNS = + +# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be +# searched for input files to be used with the \include or \dontinclude commands +# irrespective of the value of the RECURSIVE tag. +# The default value is: NO. + +EXAMPLE_RECURSIVE = NO + +# The IMAGE_PATH tag can be used to specify one or more files or directories +# that contain images that are to be included in the documentation (see the +# \image command). + +IMAGE_PATH = + +# The INPUT_FILTER tag can be used to specify a program that doxygen should +# invoke to filter for each input file. Doxygen will invoke the filter program +# by executing (via popen()) the command: +# +# +# +# where is the value of the INPUT_FILTER tag, and is the +# name of an input file. Doxygen will then use the output that the filter +# program writes to standard output. If FILTER_PATTERNS is specified, this tag +# will be ignored. +# +# Note that the filter must not add or remove lines; it is applied before the +# code is scanned, but not when the output code is generated. If lines are added +# or removed, the anchors will not be placed correctly. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +INPUT_FILTER = + +# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern +# basis. Doxygen will compare the file name with each pattern and apply the +# filter if there is a match. The filters are a list of the form: pattern=filter +# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how +# filters are used. If the FILTER_PATTERNS tag is empty or if none of the +# patterns match the file name, INPUT_FILTER is applied. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +FILTER_PATTERNS = + +# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using +# INPUT_FILTER) will also be used to filter the input files that are used for +# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES). +# The default value is: NO. + +FILTER_SOURCE_FILES = NO + +# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file +# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and +# it is also possible to disable source filtering for a specific pattern using +# *.ext= (so without naming a filter). +# This tag requires that the tag FILTER_SOURCE_FILES is set to YES. + +FILTER_SOURCE_PATTERNS = + +# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that +# is part of the input, its contents will be placed on the main page +# (index.html). This can be useful if you have a project on for instance GitHub +# and want to reuse the introduction page also for the doxygen output. + +USE_MDFILE_AS_MAINPAGE = README.md + +#--------------------------------------------------------------------------- +# Configuration options related to source browsing +#--------------------------------------------------------------------------- + +# If the SOURCE_BROWSER tag is set to YES then a list of source files will be +# generated. Documented entities will be cross-referenced with these sources. +# +# Note: To get rid of all source code in the generated output, make sure that +# also VERBATIM_HEADERS is set to NO. +# The default value is: NO. + +SOURCE_BROWSER = NO + +# Setting the INLINE_SOURCES tag to YES will include the body of functions, +# classes and enums directly into the documentation. +# The default value is: NO. + +INLINE_SOURCES = NO + +# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any +# special comment blocks from generated source code fragments. Normal C, C++ and +# Fortran comments will always remain visible. +# The default value is: YES. + +STRIP_CODE_COMMENTS = YES + +# If the REFERENCED_BY_RELATION tag is set to YES then for each documented +# function all documented functions referencing it will be listed. +# The default value is: NO. + +REFERENCED_BY_RELATION = NO + +# If the REFERENCES_RELATION tag is set to YES then for each documented function +# all documented entities called/used by that function will be listed. +# The default value is: NO. + +REFERENCES_RELATION = NO + +# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set +# to YES then the hyperlinks from functions in REFERENCES_RELATION and +# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will +# link to the documentation. +# The default value is: YES. + +REFERENCES_LINK_SOURCE = YES + +# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the +# source code will show a tooltip with additional information such as prototype, +# brief description and links to the definition and documentation. Since this +# will make the HTML file larger and loading of large files a bit slower, you +# can opt to disable this feature. +# The default value is: YES. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +SOURCE_TOOLTIPS = YES + +# If the USE_HTAGS tag is set to YES then the references to source code will +# point to the HTML generated by the htags(1) tool instead of doxygen built-in +# source browser. The htags tool is part of GNU's global source tagging system +# (see http://www.gnu.org/software/global/global.html). You will need version +# 4.8.6 or higher. +# +# To use it do the following: +# - Install the latest version of global +# - Enable SOURCE_BROWSER and USE_HTAGS in the config file +# - Make sure the INPUT points to the root of the source tree +# - Run doxygen as normal +# +# Doxygen will invoke htags (and that will in turn invoke gtags), so these +# tools must be available from the command line (i.e. in the search path). +# +# The result: instead of the source browser generated by doxygen, the links to +# source code will now point to the output of htags. +# The default value is: NO. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +USE_HTAGS = NO + +# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a +# verbatim copy of the header file for each class for which an include is +# specified. Set to NO to disable this. +# See also: Section \class. +# The default value is: YES. + +VERBATIM_HEADERS = YES + +# If the CLANG_ASSISTED_PARSING tag is set to YES then doxygen will use the +# clang parser (see: http://clang.llvm.org/) for more accurate parsing at the +# cost of reduced performance. This can be particularly helpful with template +# rich C++ code for which doxygen's built-in parser lacks the necessary type +# information. +# Note: The availability of this option depends on whether or not doxygen was +# generated with the -Duse-libclang=ON option for CMake. +# The default value is: NO. + +CLANG_ASSISTED_PARSING = NO + +# If clang assisted parsing is enabled you can provide the compiler with command +# line options that you would normally use when invoking the compiler. Note that +# the include paths will already be set by doxygen for the files and directories +# specified with INPUT and INCLUDE_PATH. +# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. + +CLANG_OPTIONS = + +#--------------------------------------------------------------------------- +# Configuration options related to the alphabetical class index +#--------------------------------------------------------------------------- + +# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all +# compounds will be generated. Enable this if the project contains a lot of +# classes, structs, unions or interfaces. +# The default value is: YES. + +ALPHABETICAL_INDEX = YES + +# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in +# which the alphabetical index list will be split. +# Minimum value: 1, maximum value: 20, default value: 5. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +COLS_IN_ALPHA_INDEX = 5 + +# In case all classes in a project start with a common prefix, all classes will +# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag +# can be used to specify a prefix (or a list of prefixes) that should be ignored +# while generating the index headers. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +IGNORE_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the HTML output +#--------------------------------------------------------------------------- + +# If the GENERATE_HTML tag is set to YES, doxygen will generate HTML output +# The default value is: YES. + +GENERATE_HTML = YES + +# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_OUTPUT = html + +# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each +# generated HTML page (for example: .htm, .php, .asp). +# The default value is: .html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FILE_EXTENSION = .html + +# The HTML_HEADER tag can be used to specify a user-defined HTML header file for +# each generated HTML page. If the tag is left blank doxygen will generate a +# standard header. +# +# To get valid HTML the header file that includes any scripts and style sheets +# that doxygen needs, which is dependent on the configuration options used (e.g. +# the setting GENERATE_TREEVIEW). It is highly recommended to start with a +# default header using +# doxygen -w html new_header.html new_footer.html new_stylesheet.css +# YourConfigFile +# and then modify the file new_header.html. See also section "Doxygen usage" +# for information on how to generate the default header that doxygen normally +# uses. +# Note: The header is subject to change so you typically have to regenerate the +# default header when upgrading to a newer version of doxygen. For a description +# of the possible markers and block names see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_HEADER = + +# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each +# generated HTML page. If the tag is left blank doxygen will generate a standard +# footer. See HTML_HEADER for more information on how to generate a default +# footer and what special commands can be used inside the footer. See also +# section "Doxygen usage" for information on how to generate the default footer +# that doxygen normally uses. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FOOTER = + +# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style +# sheet that is used by each HTML page. It can be used to fine-tune the look of +# the HTML output. If left blank doxygen will generate a default style sheet. +# See also section "Doxygen usage" for information on how to generate the style +# sheet that doxygen normally uses. +# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as +# it is more robust and this tag (HTML_STYLESHEET) will in the future become +# obsolete. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_STYLESHEET = + +# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined +# cascading style sheets that are included after the standard style sheets +# created by doxygen. Using this option one can overrule certain style aspects. +# This is preferred over using HTML_STYLESHEET since it does not replace the +# standard style sheet and is therefore more robust against future updates. +# Doxygen will copy the style sheet files to the output directory. +# Note: The order of the extra style sheet files is of importance (e.g. the last +# style sheet in the list overrules the setting of the previous ones in the +# list). For an example see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_STYLESHEET = + +# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or +# other source files which should be copied to the HTML output directory. Note +# that these files will be copied to the base HTML output directory. Use the +# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these +# files. In the HTML_STYLESHEET file, use the file name only. Also note that the +# files will be copied as-is; there are no commands or markers available. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_FILES = + +# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen +# will adjust the colors in the style sheet and background images according to +# this color. Hue is specified as an angle on a colorwheel, see +# http://en.wikipedia.org/wiki/Hue for more information. For instance the value +# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 +# purple, and 360 is red again. +# Minimum value: 0, maximum value: 359, default value: 220. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_HUE = 220 + +# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors +# in the HTML output. For a value of 0 the output will use grayscales only. A +# value of 255 will produce the most vivid colors. +# Minimum value: 0, maximum value: 255, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_SAT = 100 + +# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the +# luminance component of the colors in the HTML output. Values below 100 +# gradually make the output lighter, whereas values above 100 make the output +# darker. The value divided by 100 is the actual gamma applied, so 80 represents +# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not +# change the gamma. +# Minimum value: 40, maximum value: 240, default value: 80. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_GAMMA = 80 + +# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML +# page will contain the date and time when the page was generated. Setting this +# to YES can help to show when doxygen was last run and thus if the +# documentation is up to date. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_TIMESTAMP = NO + +# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML +# documentation will contain sections that can be hidden and shown after the +# page has loaded. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_SECTIONS = NO + +# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries +# shown in the various tree structured indices initially; the user can expand +# and collapse entries dynamically later on. Doxygen will expand the tree to +# such a level that at most the specified number of entries are visible (unless +# a fully collapsed tree already exceeds this amount). So setting the number of +# entries 1 will produce a full collapsed tree by default. 0 is a special value +# representing an infinite number of entries and will result in a full expanded +# tree by default. +# Minimum value: 0, maximum value: 9999, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_INDEX_NUM_ENTRIES = 100 + +# If the GENERATE_DOCSET tag is set to YES, additional index files will be +# generated that can be used as input for Apple's Xcode 3 integrated development +# environment (see: http://developer.apple.com/tools/xcode/), introduced with +# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a +# Makefile in the HTML output directory. Running make will produce the docset in +# that directory and running make install will install the docset in +# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at +# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html +# for more information. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_DOCSET = NO + +# This tag determines the name of the docset feed. A documentation feed provides +# an umbrella under which multiple documentation sets from a single provider +# (such as a company or product suite) can be grouped. +# The default value is: Doxygen generated docs. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_FEEDNAME = "Doxygen generated docs" + +# This tag specifies a string that should uniquely identify the documentation +# set bundle. This should be a reverse domain-name style string, e.g. +# com.mycompany.MyDocSet. Doxygen will append .docset to the name. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_BUNDLE_ID = org.doxygen.Project + +# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify +# the documentation publisher. This should be a reverse domain-name style +# string, e.g. com.mycompany.MyDocSet.documentation. +# The default value is: org.doxygen.Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_ID = org.doxygen.Publisher + +# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher. +# The default value is: Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_NAME = Publisher + +# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three +# additional HTML index files: index.hhp, index.hhc, and index.hhk. The +# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop +# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# Windows. +# +# The HTML Help Workshop contains a compiler that can convert all HTML output +# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML +# files are now used as the Windows 98 help format, and will replace the old +# Windows help format (.hlp) on all Windows platforms in the future. Compressed +# HTML files also contain an index, a table of contents, and you can search for +# words in the documentation. The HTML workshop also contains a viewer for +# compressed HTML files. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_HTMLHELP = NO + +# The CHM_FILE tag can be used to specify the file name of the resulting .chm +# file. You can add a path in front of the file if the result should not be +# written to the html output directory. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_FILE = + +# The HHC_LOCATION tag can be used to specify the location (absolute path +# including file name) of the HTML help compiler (hhc.exe). If non-empty, +# doxygen will try to run the HTML help compiler on the generated index.hhp. +# The file has to be specified with full path. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +HHC_LOCATION = + +# The GENERATE_CHI flag controls if a separate .chi index file is generated +# (YES) or that it should be included in the master .chm file (NO). +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +GENERATE_CHI = NO + +# The CHM_INDEX_ENCODING is used to encode HtmlHelp index (hhk), content (hhc) +# and project file content. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_INDEX_ENCODING = + +# The BINARY_TOC flag controls whether a binary table of contents is generated +# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it +# enables the Previous and Next buttons. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +BINARY_TOC = NO + +# The TOC_EXPAND flag can be set to YES to add extra items for group members to +# the table of contents of the HTML help documentation and to the tree view. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +TOC_EXPAND = NO + +# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and +# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that +# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help +# (.qch) of the generated HTML documentation. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_QHP = NO + +# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify +# the file name of the resulting .qch file. The path specified is relative to +# the HTML output folder. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QCH_FILE = + +# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help +# Project output. For more information please see Qt Help Project / Namespace +# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace). +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_NAMESPACE = org.doxygen.Project + +# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt +# Help Project output. For more information please see Qt Help Project / Virtual +# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual- +# folders). +# The default value is: doc. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_VIRTUAL_FOLDER = doc + +# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom +# filter to add. For more information please see Qt Help Project / Custom +# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_NAME = + +# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the +# custom filter to add. For more information please see Qt Help Project / Custom +# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_ATTRS = + +# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this +# project's filter section matches. Qt Help Project / Filter Attributes (see: +# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_SECT_FILTER_ATTRS = + +# The QHG_LOCATION tag can be used to specify the location of Qt's +# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the +# generated .qhp file. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHG_LOCATION = + +# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be +# generated, together with the HTML files, they form an Eclipse help plugin. To +# install this plugin and make it available under the help contents menu in +# Eclipse, the contents of the directory containing the HTML and XML files needs +# to be copied into the plugins directory of eclipse. The name of the directory +# within the plugins directory should be the same as the ECLIPSE_DOC_ID value. +# After copying Eclipse needs to be restarted before the help appears. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_ECLIPSEHELP = NO + +# A unique identifier for the Eclipse help plugin. When installing the plugin +# the directory name containing the HTML and XML files should also have this +# name. Each documentation set should have its own identifier. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES. + +ECLIPSE_DOC_ID = org.doxygen.Project + +# If you want full control over the layout of the generated HTML pages it might +# be necessary to disable the index and replace it with your own. The +# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top +# of each HTML page. A value of NO enables the index and the value YES disables +# it. Since the tabs in the index contain the same information as the navigation +# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +DISABLE_INDEX = NO + +# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index +# structure should be generated to display hierarchical information. If the tag +# value is set to YES, a side panel will be generated containing a tree-like +# index structure (just like the one that is generated for HTML Help). For this +# to work a browser that supports JavaScript, DHTML, CSS and frames is required +# (i.e. any modern browser). Windows users are probably better off using the +# HTML help feature. Via custom style sheets (see HTML_EXTRA_STYLESHEET) one can +# further fine-tune the look of the index. As an example, the default style +# sheet generated by doxygen has an example that shows how to put an image at +# the root of the tree instead of the PROJECT_NAME. Since the tree basically has +# the same information as the tab index, you could consider setting +# DISABLE_INDEX to YES when enabling this option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_TREEVIEW = NO + +# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that +# doxygen will group on one line in the generated HTML documentation. +# +# Note that a value of 0 will completely suppress the enum values from appearing +# in the overview section. +# Minimum value: 0, maximum value: 20, default value: 4. +# This tag requires that the tag GENERATE_HTML is set to YES. + +ENUM_VALUES_PER_LINE = 4 + +# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used +# to set the initial width (in pixels) of the frame in which the tree is shown. +# Minimum value: 0, maximum value: 1500, default value: 250. +# This tag requires that the tag GENERATE_HTML is set to YES. + +TREEVIEW_WIDTH = 250 + +# If the EXT_LINKS_IN_WINDOW option is set to YES, doxygen will open links to +# external symbols imported via tag files in a separate window. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +EXT_LINKS_IN_WINDOW = NO + +# Use this tag to change the font size of LaTeX formulas included as images in +# the HTML documentation. When you change the font size after a successful +# doxygen run you need to manually remove any form_*.png images from the HTML +# output directory to force them to be regenerated. +# Minimum value: 8, maximum value: 50, default value: 10. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_FONTSIZE = 10 + +# Use the FORMULA_TRANPARENT tag to determine whether or not the images +# generated for formulas are transparent PNGs. Transparent PNGs are not +# supported properly for IE 6.0, but are supported on all modern browsers. +# +# Note that when changing this option you need to delete any form_*.png files in +# the HTML output directory before the changes have effect. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_TRANSPARENT = YES + +# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see +# http://www.mathjax.org) which uses client side Javascript for the rendering +# instead of using pre-rendered bitmaps. Use this if you do not have LaTeX +# installed or if you want to formulas look prettier in the HTML output. When +# enabled you may also need to install MathJax separately and configure the path +# to it using the MATHJAX_RELPATH option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +USE_MATHJAX = NO + +# When MathJax is enabled you can set the default output format to be used for +# the MathJax output. See the MathJax site (see: +# http://docs.mathjax.org/en/latest/output.html) for more details. +# Possible values are: HTML-CSS (which is slower, but has the best +# compatibility), NativeMML (i.e. MathML) and SVG. +# The default value is: HTML-CSS. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_FORMAT = HTML-CSS + +# When MathJax is enabled you need to specify the location relative to the HTML +# output directory using the MATHJAX_RELPATH option. The destination directory +# should contain the MathJax.js script. For instance, if the mathjax directory +# is located at the same level as the HTML output directory, then +# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax +# Content Delivery Network so you can quickly see the result without installing +# MathJax. However, it is strongly recommended to install a local copy of +# MathJax from http://www.mathjax.org before deployment. +# The default value is: http://cdn.mathjax.org/mathjax/latest. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest + +# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax +# extension names that should be enabled during MathJax rendering. For example +# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_EXTENSIONS = + +# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces +# of code that will be used on startup of the MathJax code. See the MathJax site +# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# example see the documentation. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_CODEFILE = + +# When the SEARCHENGINE tag is enabled doxygen will generate a search box for +# the HTML output. The underlying search engine uses javascript and DHTML and +# should work on any modern browser. Note that when using HTML help +# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET) +# there is already a search function so this one should typically be disabled. +# For large projects the javascript based search engine can be slow, then +# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to +# search using the keyboard; to jump to the search box use + S +# (what the is depends on the OS and browser, but it is typically +# , /